diff --git a/.gitignore b/.gitignore index 6ff753a67..96efdba0c 100644 --- a/.gitignore +++ b/.gitignore @@ -18,6 +18,9 @@ package-lock.json test.kk *.pdb *.pdn +*.vcxproj.user +*.vcxproj.interactive +*. *~ *.exe *.vsix diff --git a/doc/spec/book.kk.md b/doc/spec/book.kk.md index c84461c3f..e62c6d611 100644 --- a/doc/spec/book.kk.md +++ b/doc/spec/book.kk.md @@ -25,10 +25,16 @@ body { .colored } -~bar : before='|' -~many : before='{ ' after=' }' -~opt : before='[ ' after=' ]' - +bar: [|]{padding:0ex 0.25ex} + +~many : before='{ '; after=' }' +~manyn : before='{ '; after=' }~_n_~' +~manyx : before='{ '; after=' }' +~opt : before='[ '; after=' ]' +~diff { + before: '~[~' +} [koka-logo]: images/koka-logo-filled.png { max-height: 120px; padding:1rem 1rem 1rem 1.5rem; } diff --git a/doc/spec/grammar/lexer.l b/doc/spec/grammar/lexer.l index 2f47b3bd8..69c280ef8 100644 --- a/doc/spec/grammar/lexer.l +++ b/doc/spec/grammar/lexer.l @@ -1,1401 +1,1412 @@ -/* Copyright 2012-2021, Microsoft Research, Daan Leijen - This is free software; you can redistribute it and/or modify it under the - terms of the Apache License, Version 2.0. -*/ -/* Use the "Yash" extension in vscode for nice syntax highlighting. - Requires at least Flex 2.5.37; you can get a version for windows from - https://sourceforge.net/projects/winflexbison -*/ -%option 8bit noyywrap bison-bridge bison-locations reentrant - -/* Exclusive Lexer states */ -%x comment -%x linecomment -%x string -%x rawstring - -%{ -#define CHECK_BALANCED // check balanced parenthesis -#define INSERT_CLOSE_BRACE -#define INSERT_OPEN_BRACE -#define INDENT_LAYOUT // use full layout rule based on nested indentation -#undef LINE_LAYOUT // use simple layout based on line ending token - -/* Standard types and includes */ -typedef int bool; -#define true (1==1) -#define false (!true) - -#include "stdlib.h" -#include "string.h" -#include "stdarg.h" -#include "assert.h" -#include "parser.tab.h" - -/* The extra scanner state */ -#define YY_EXTRA_TYPE struct _ExtraState* - -/* Errors */ -void yyerror( YYLTYPE* loc, yyscan_t scanner, char* s, ... ); -void illegal( char* s, yyscan_t scanner ); -void illegalchar( char c, char* s, yyscan_t scanner ); - -/* Comments */ -void commentNestingInc(yyscan_t scanner); -int commentNestingDec(yyscan_t scanner); - -/* Numbers */ -double numdouble( const char* s ); -long numlong( const char* s, int base ); - -/* Allocation of identifiers and string literals */ -char* identifier( const char* s, yyscan_t scanner, bool wellformedCheck ); -char* stringDup( const char* s, yyscan_t scanner ); -void stringStart( yyscan_t scanner ); -void stringAdd( unsigned int c, yyscan_t scanner); -void stringAddStr( const char* s, yyscan_t scanner ); -char* stringEnd( yyscan_t scanner ); -unsigned int utfDecode( const char* buf, int len, yyscan_t scanner ); - -/* Raw string delimiter length */ -void rawStringSetDelimCount( int count, yyscan_t scanner ); -int rawStringGetDelimCount( yyscan_t scanner ); - -/* Character escape codes */ -char escapeToChar( char esc, yyscan_t scanner ) -{ - switch(esc) { - case 'n' : return '\n'; - case 'r' : return '\r'; - case 't' : return '\t'; - case '\\': return '\\'; - case '"' : return '"'; - case '\'': return '\''; - default : illegalchar(esc,"escape code",scanner); - return esc; - } -} - -%} - - /* Character classes */ - -Symbols {Symbol}+|[/] -Symbol [\$\%\&\*\+\@!\\\^\~=\.\-\:\?\|\<\>] -AngleBar [\<\>\|] -Angle [\<\>] -Sign [\-]? - -ConId {Upper}{IdChar}*{Final}* -Id {Lower}{IdChar}*{Final}* -IdChar {Letter}|{Digit}|[_\-] - -HexEsc x{Hex}{Hex}|u{Hex}{Hex}{Hex}{Hex}|U{Hex}{Hex}{Hex}{Hex}{Hex}{Hex} -CharEsc [nrt\\\"\'] -/* for editor highlighting " */ - -LineChar {GraphicLine}|{Utf8} -BlockChar {GraphicBlock}|{Utf8} - -Decimal 0|[1-9](_?{Digits})? -HexaDecimal 0[xX]{HexDigits} - -Digits {Digit}+{DigitSep}* -HexDigits {Hex}+{HexSep}* - -DigitSep _{Digit}+ -HexSep _{Hex}+ - -Letter {Lower}|{Upper} -Upper [A-Z] -Lower [a-z] -Digit [0-9] -Hex [0-9a-fA-F] -Space [ \t] -Newline [\r]?[\n] -Final [\'] -/* for editor highlighting ' */ - -GraphicChar [ \x21-\x26\x28-\[\]-\x7E] -GraphicStr [ \x21\x23-\[\]-\x7E] -GraphicRaw [\t \n\r\x21\x23-\x7E] -GraphicLine [\t \x21-\x7E] -GraphicBlock [\t \x21-\)\+-\.0-\x7E] - - /* Valid UTF-8 sequences. Based on http://www.w3.org/2005/03/23-lex-U - Added \xC0\x80 as a valid sequence to represent 0 (also called 'modified' utf-8) - */ -UC [\x80-\xBF] -U2 [\xC2-\xDF]{UC} -U3 [\xE0][\xA0-\xBF]{UC}|[\xE1-\xEC]{UC}{UC}|[\xED][\x80-\x9F]{UC}|[\xEE-\xEF]{UC}{UC} -U4 [\xF0][\x90-\xBF]{UC}{UC}|[\xF1-\xF3]{UC}{UC}{UC}|[\xF4][\x80-\x8F]{UC}{UC} -Utf8 {U2}|{U3}|{U4} - - -%% - - /* -------- INITIAL ------------- */ - - /* keywords */ -infix { return INFIX; } -infixl { return INFIXL; } -infixr { return INFIXR; } - -type { return TYPE; } -alias { return ALIAS; } -struct { return STRUCT; } -effect { return EFFECT; } - -forall { return FORALL; } -exists { return EXISTS; } -some { return SOME; } - -abstract { return ABSTRACT; } -extern { return EXTERN; } - -fun { return FUN; } -fn { return FN; } -val { return VAL; } -var { return VAR; } -con { return CON; } - -if { return IF;} -then { return THEN; } -else { return ELSE;} -elif { return ELIF;} -with { return WITH; } -in { return IN; } -match { return MATCH;} -return { return RETURN;} - -module { return MODULE;} -import { return IMPORT;} -pub { return PUB;} -as { return AS;} - -handle { return HANDLE; } -handler { return HANDLER; } -ctl { return CTL; } -final { return FINAL; } -raw { return RAW; } -mask { return MASK; } -override { return OVERRIDE; } -named { return NAMED; } - -rec { return ID_REC; } -co { return ID_CO; } -open { return ID_OPEN; } -extend { return ID_EXTEND; } -linear { return ID_LINEAR; } -value { return ID_VALUE; } -reference { return ID_REFERENCE; } - -inline { return ID_INLINE; } -noinline { return ID_NOINLINE;} -scoped { return ID_SCOPED; } -behind { return ID_BEHIND; } -initially { return ID_INITIALLY; } -finally { return ID_FINALLY; } - - /* unused reserved identifiers */ -interface { return IFACE; } -break { return BREAK; } -continue { return CONTINUE; } -unsafe { return UNSAFE; } - - /* reserved operators */ -: { return ':'; } -= { return '='; } -\. { return '.'; } -\-\> { return RARROW; } -\<\- { return LARROW; } - - /* special operators and identifiers (not reserved but have special meaning in certain contexts) */ -:= { return ASSIGN; } -:: { return DCOLON; } -\| { return '|'; } -\< { return '<'; } -\> { return '>'; } -! { return '!'; } -\^ { return '^'; } -~ { return '~'; } - -file { return ID_FILE; } -cs { return ID_CS; } -js { return ID_JS; } -c { return ID_C; } - - /* Special symbols (cannot be an operator) */ -\) { return ')'; } -\( { return '('; } -\{ { return '{'; } -\} { return '}'; } -\[ { return '['; } -\] { return ']'; } -; { return ';'; } -, { return ','; } -` { return '`'; } - - /* Comments */ -\/\/ { BEGIN(linecomment); yymore(); } -\/\* { BEGIN(comment); commentNestingInc(yyscanner); yyless(2); yymore(); } - - /* Type operators: these are all illegal operators and should be parsed as single characters - For example, in types, we can have sequences like "<|>" where "<<", ">|<", and ">>" - should not be parsed as operator tokens. */ -\|\| { yylval->Id = identifier(yytext,yyscanner,false); return OP; } -{AngleBar}{AngleBar}+ { yyless(1); return yytext[0]; } - - /* Numbers */ -{Sign}{Decimal}\.{Digits}[eE][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } -{Sign}{Decimal}[eE][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } -{Sign}{Decimal}\.{Digits} { yylval->Float = numdouble(yytext); return FLOAT; } - -{Sign}{HexaDecimal}\.{HexDigits}[pP][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } -{Sign}{HexaDecimal}[pP][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } -{Sign}{HexaDecimal}\.{HexDigits} { yylval->Float = numdouble(yytext); return FLOAT; } - -{Sign}{HexaDecimal} { yylval->Int = numlong(yytext+2,16); return INT; } -{Sign}{Decimal} { yylval->Int = numlong(yytext,10); return INT; } - - - /* Identifiers and operators */ -({Id}\/)+{ConId} { yylval->Id = identifier(yytext,yyscanner,true); return QCONID; } -({Id}\/)+{Id} { yylval->Id = identifier(yytext,yyscanner,true); return QID; } -({Id}\/)+\({Symbols}\) { yylval->Id = identifier(yytext,yyscanner,true); return QIDOP; } - -{ConId} { yylval->Id = identifier(yytext,yyscanner,true); return CONID; } -{Id} { yylval->Id = identifier(yytext,yyscanner,true); return ID; } -\({Symbols}\) { yylval->Id = identifier(yytext,yyscanner,false); return IDOP; } -{Symbols} { yylval->Id = identifier(yytext,yyscanner,false); return OP; } -_{IdChar}* { yylval->Id = identifier(yytext,yyscanner,true); return WILDCARD; } - - /* Character literals */ -\'{GraphicChar}\' { yylval->Char = yytext[1]; return CHAR; } -\'\\{HexEsc}\' { yylval->Char = strtol(yytext+3,NULL,16); return CHAR; } -\'\\{CharEsc}\' { yylval->Char = escapeToChar(yytext[2],yyscanner); return CHAR; } -\'{Utf8}\' { yylval->Char = utfDecode(yytext+1,yyleng-2,yyscanner); return CHAR; } -\'.\' { illegalchar(yytext[1],"character literal",yyscanner); - yylval->Char = ' '; - return CHAR; - } -\'. { illegal("illegal character literal",yyscanner); // ' - yylval->Char = ' '; - return CHAR; - } - - /* String literal start */ -\" { BEGIN(string); // " - stringStart(yyscanner); - yymore(); - } - - /* Raw string literal start */ -r#*\" { BEGIN(rawstring); /* " for editor highlighting */ - rawStringSetDelimCount(yyleng-1,yyscanner); - stringStart(yyscanner); - yyless(yyleng); - yymore(); - } - - /* White space */ -{Space}+ { return LEX_WHITE; } -{Newline} { return LEX_WHITE; } -. { illegalchar(yytext[yyleng-1],NULL,yyscanner); - return LEX_WHITE; - } - - /* --------- Raw string literals --------- */ -\"#* { int count = rawStringGetDelimCount(yyscanner); - int scanned = yyleng - YY_MORE_ADJ; - if (count > scanned) { - // keep going - stringAddStr(yytext + YY_MORE_ADJ, yyscanner ); - yymore(); - } - else { - // end of string - if (count < scanned) illegalchar('#',"raw string terminated with too many '#' characters", yyscanner); - BEGIN(INITIAL); - yylval->String = stringEnd(yyscanner); - return STRING; - } - } -{GraphicRaw}+ { stringAddStr(yytext + YY_MORE_ADJ, yyscanner ); - yymore(); - } -{Utf8} { stringAdd(utfDecode(yytext+YY_MORE_ADJ,yyleng-YY_MORE_ADJ,yyscanner), yyscanner); yymore(); } -. { illegalchar(yytext[yyleng-1],"raw string", yyscanner); - yymore(); - } - - /* --------- String literals --------- */ -\" { BEGIN(INITIAL); // " - yylval->String = stringEnd(yyscanner); - return STRING; - } -{GraphicStr}+ { char* p = yytext + YY_MORE_ADJ; - while (*p) { - stringAdd( *p++, yyscanner); - } - yymore(); - } -\\{HexEsc} { stringAdd(strtol(yytext+2+YY_MORE_ADJ,NULL,16),yyscanner); yymore(); } -\\{CharEsc} { stringAdd(escapeToChar(yytext[1+YY_MORE_ADJ],yyscanner),yyscanner); yymore(); } -{Utf8} { stringAdd(utfDecode(yytext+YY_MORE_ADJ,yyleng-YY_MORE_ADJ,yyscanner),yyscanner); yymore(); } - -{Newline} { BEGIN(INITIAL); - illegal( "illegal newline ends string", yyscanner ); - yylval->String = stringEnd(yyscanner); - return STRING; - } -. { illegalchar(yytext[yyleng-1],"string", yyscanner); - yymore(); - } - - - /* ---------- Comments ------------ " */ -{BlockChar}+ { yymore(); } -\/\* { commentNestingInc(yyscanner); yymore(); } -\*\/ { if (commentNestingDec(yyscanner) == 0) { - BEGIN(INITIAL); - return LEX_COMMENT; - } - else yymore(); - } -\* { yymore(); } -\/ { yymore(); } -{Newline} { return LEX_COMMENT; } -. { illegalchar(yytext[yyleng-1], "comment", yyscanner); - yymore(); - } - -{LineChar}+ { yymore(); } -{Newline} { BEGIN(INITIAL); return LEX_COMMENT; } -. { illegalchar( yytext[yyleng-1], "line comment", yyscanner ); - yymore(); - } - -%% - -/* Enable the use of regular Flex macros (like yyextra) inside user defined functions */ -#define EnableMacros(s) yyget_extra(s); struct yyguts_t* yyg = (struct yyguts_t*)(s); - - -/* Keep a list of allocated memory - in order to free all allocated identifiers and string literals afterwards*/ -typedef struct _allocList* allocList; - -void alistAdd ( allocList* list, void* p ); -void alistFree( allocList* list ); - -// show character or string -char* showChar( unsigned int c, yyscan_t scanner ); -char* showString( const char* s, yyscan_t scanner ); - -/*--------------------------------------------------------- - The extra state - This is used to maintain: - - nesting level of comments - - the precise position - - the previous token - - the layout stack for semicolon insertion - - the saved token when a semicolon was inserted - - a buffer for string literals - - an allocation list to free allocated identifiers and string literals. - - the number of errors ----------------------------------------------------------*/ -#define errorMax 1 // 25 -#define layoutMax 255 /* Limit maximal layout stack to 255 for simplicity */ -#define braceMax 255 /* maximal nesting depth of parenthesis */ -#define Token int -#define savedMax 255 - -typedef struct _ExtraState { - /* nested comments */ - int commentNesting; - - /* raw string delimiter count */ - int delimCount; - - /* precise position */ - int column; - int line; - - /* layout stack */ - bool noLayout; // apply the layout rule and insert semicolons? */ -#ifdef INDENT_LAYOUT - int layoutTop; - int layout[layoutMax]; - - /* location of the last seen comment -- used to prevent comments in indentation */ - YYLTYPE commentLoc; -#endif - -#ifdef CHECK_BALANCED - /* balanced braces */ - int braceTop; - Token braces[braceMax]; - YYLTYPE bracesLoc[braceMax]; -#endif - - /* the previous non-white token and its location */ - Token previous; - YYLTYPE previousLoc; - - /* the saved token and location: used to insert semicolons */ - int savedTop; - Token savedToken[savedMax]; - YYLTYPE savedLoc[savedMax]; - - /* temporary string buffer for string literals */ - int stringMax; - int stringLen; - char* stringBuf; - - /* list of storage for yylval allocations */ - allocList allocated; - - /* number of calls to yyerror */ - int errorCount; - - /* be verbose */ - int verbose; - - /* tab size used for error reporting */ - int tab; - -} ExtraState; - -/* Forward declarations on the state */ -YYLTYPE updateLoc( yyscan_t scanner ); /* update the location after yylex returns */ -void printToken( int token, int state, yyscan_t scanner ); /* print a token for debugging purposes */ - -/*---------------------------------------------------- - For semi-colon insertion, we look at the tokens that - end statements, and ones that continue a statement -----------------------------------------------------*/ -static int find( Token tokens[], Token token ) -{ - int i = 0; - while (tokens[i] != 0) { - if (tokens[i] == token) return i; - i++; - } - return -1; -} - -static bool contains( Token tokens[], Token token ) { - return (find(tokens,token) >= 0); -} - -static Token appTokens[] = { ')', ']', '>', ID, CONID, IDOP, QID, QCONID, QIDOP, 0 }; - -static bool isAppToken( Token token ) { - return contains(appTokens, token ); -} - - -#ifdef INDENT_LAYOUT - static Token continuationTokens[] = { ')', '>', ']', ',', '{', '}', '|', ':', '.', '=', ASSIGN, OP, THEN, ELSE, ELIF, RARROW, LARROW, 0 }; - // { THEN, ELSE, ELIF, ')', ']', '{', 0 }; - - static bool continuationToken( Token token ) { - return contains(continuationTokens, token ); - } -#endif - - -#ifdef INSERT_OPEN_BRACE - static Token endingTokens[] = { '(', '<', '[', ',', '{', '.', OP, 0 }; - - bool endingToken( Token token ) { - return contains(endingTokens,token); - } -#endif - -#ifdef LINE_LAYOUT - static Token endingTokens[] = { ID, CONID, IDOP, QIDOP, QID, QCONID, INT, FLOAT, STRING, CHAR, ')', ']', '}', '>', 0 }; - static Token continueTokens[] = { THEN, ELSE, ELIF, '=', '{', '}', ')', ']', '>', 0 }; - - bool endingToken( Token token ) { - return contains(endingTokens,token); - } - - bool continueToken( Token token ) { - return contains(continueTokens,token); - } -#endif - -#ifdef CHECK_BALANCED - static Token closeTokens[] = { ')', '}', ']', /* ')', ']',*/ 0 }; - static Token openTokens[] = { '(', '{', '[', /* APP, IDX,*/ 0 }; - - Token isCloseBrace( Token token ) { - int i = find(closeTokens,token); - return (i >= 0 ? openTokens[i] : -1); - } - - Token isOpenBrace( Token token ) { - int i = find(openTokens,token); - return (i >= 0 ? closeTokens[i] : -1); - } -#endif - - -static void savedPush( YY_EXTRA_TYPE extra, Token token, YYLTYPE* loc ) { - assert(extra->savedTop < savedMax); - extra->savedTop++; - extra->savedToken[extra->savedTop] = token; - extra->savedLoc[extra->savedTop] = *loc; - // fprintf(stderr, "save token (%d,%d): %c (0x%04x) (new top: %d)\n", loc->first_line, loc->first_column, token, token, extra->savedTop ); -} - -static void savedPop( YY_EXTRA_TYPE extra, Token* token, YYLTYPE* loc ) { - assert(extra->savedTop >= 0); - *token = extra->savedToken[extra->savedTop]; - *loc = extra->savedLoc[extra->savedTop]; - extra->savedTop--; - // fprintf(stderr, "restore from saved (%d,%d): %c (0x%04x) (new top: %d)\n", loc->first_line, loc->first_column, *token, *token, extra->savedTop ); -} - -/*---------------------------------------------------- - Main lexical analysis routine 'mylex' -----------------------------------------------------*/ - -Token mylex( YYSTYPE* lval, YYLTYPE* loc, yyscan_t scanner) -{ - EnableMacros(scanner); - Token token; - int startState = YYSTATE; - - // do we have a saved token? - if (yyextra->savedTop >= 0) { - // fprintf(stderr,"have saved: %d\n", yyextra->savedTop); - savedPop( yyextra, &token, loc ); - } - - // if not, scan ahead - else { - token = yylex( lval, loc, scanner ); - *loc = updateLoc( scanner ); - - /* - // this is to avoid needing semicolons - if (token=='(' && isAppToken(yyextra->previous)) token = APP; - if (token=='[' && isAppToken(yyextra->previous)) token = IDX; - */ - - // skip whitespace - while (token == LEX_WHITE || token == LEX_COMMENT) { -#ifdef INDENT_LAYOUT - // save last comment location (to check later if it was not part of indentation) - if (token == LEX_COMMENT) { - yyextra->commentLoc = *loc; - } -#endif - // scan again - token = yylex( lval, loc, scanner ); - *loc = updateLoc(scanner); - } - } - - - - if (yyextra->previous != INSERTED_SEMI) { -#ifdef CHECK_BALANCED - // check balanced braces - Token closeBrace = isOpenBrace(token); - //fprintf(stderr,"scan: %d, %d, (%d,%d)\n", token, closeBrace, loc->first_line, loc->first_column); - if (closeBrace>=0) { - if (yyextra->braceTop >= (braceMax-1)) { - yyerror(loc,scanner, "maximal nesting level of braces reached"); - } - else { - // push the close brace - yyextra->braceTop++; - yyextra->braces[yyextra->braceTop] = closeBrace; - yyextra->bracesLoc[yyextra->braceTop] = *loc; - } - } - else if (isCloseBrace(token) >= 0) { - // check if the close brace matches the context - if (yyextra->braceTop < 0) { - yyerror(loc, scanner, "unbalanced braces: '%c' is not opened", token); - } - else if (yyextra->braces[yyextra->braceTop] != token) { - YYLTYPE openLoc = yyextra->bracesLoc[yyextra->braceTop]; - // try to pop to nearest open brace; otherwise don't pop at all - int top = yyextra->braceTop-1; - while( top >= 0 && yyextra->braces[top] != token) top--; - if (top >= 0) { - // there is a matching open brace on the stack - yyerror(&openLoc, scanner, "unbalanced braces: '%c' is not closed", isCloseBrace(yyextra->braces[yyextra->braceTop]) ); - yyextra->braceTop = top-1; // pop to matching one - } - else { - // no matching brace - yyerror(loc, scanner, "unbalanced braces: '%c' is not opened", token ); //, yyextra->braces[yyextra->braceTop],openLoc.first_line,openLoc.first_column); - } - } - else { - // pop - yyextra->braceTop--; - } - } -#endif - - // Do layout ? - if (!yyextra->noLayout) - { - bool newline = (yyextra->previousLoc.last_line < loc->first_line); - -#ifdef INDENT_LAYOUT - // set a new layout context? - if (yyextra->previous == '{') { - if (token != '}' && loc->first_column <= yyextra->layout[yyextra->layoutTop]) { - yyerror(loc,scanner,"illegal layout start; the line must be indented at least as much as its enclosing layout context (column %d)", yyextra->layout[yyextra->layoutTop-1]); - } - if (yyextra->verbose) { - fprintf(stderr," layout start: %d\n", loc->first_column); - } - - if (yyextra->layoutTop == layoutMax) { - yyerror(loc,scanner,"maximal layout nesting level reached!"); - } - else { - yyextra->layoutTop++; - yyextra->layout[yyextra->layoutTop] = loc->first_column; - } - } - - // pop from the layout stack? - if (token == '}') { - if (yyextra->layoutTop <= 1) { - yyerror(loc,scanner,"unexpected closing brace"); - } - else { - if (yyextra->verbose) { - fprintf( stderr, " layout end %d\n", yyextra->layout[yyextra->layoutTop] ); - } - yyextra->layoutTop--; - } - } - - int layoutColumn = yyextra->layout[yyextra->layoutTop]; - - if (newline) { - // check comment in indentation - if (yyextra->commentLoc.last_line == loc->first_line) { - yyerror(&yyextra->commentLoc,scanner,"comments are not allowed in indentation; rewrite by putting the comment on its own line or at the end of the line"); - } - #ifndef INSERT_CLOSE_BRACE - // check layout - if (loc->first_column < layoutColumn) { - yyerror(loc,scanner,"illegal layout: the line must be indented at least as much as its enclosing layout context (column %d)", layoutColumn); - } - #else - if (token != '}' && loc->first_column < layoutColumn && yyextra->layoutTop > 1) { - // fprintf(stderr,"line (%d,%d): insert }, layout col: %d\n", loc->first_line, loc->first_column, yyextra->layoutTop); - // pop layout column - yyextra->layoutTop--; - layoutColumn = yyextra->layout[yyextra->layoutTop]; - - // save the currently scanned token - savedPush(yyextra, token, loc); - - // and replace it by a closing brace - *loc = yyextra->previousLoc; - loc->first_line = loc->last_line; - loc->first_column = loc->last_column; - loc->last_column++; - token = '}'; - } - #endif - } - - // insert a semi colon? - if ( // yyextra->previous != INSERTED_SEMI && - ((newline && loc->first_column == layoutColumn && !continuationToken(token)) - || token == '}' || token == 0)) - { - // fprintf(stderr,"insert semi before: %c (0x%04x), top: %d\n", token, token, yyextra->savedTop); - // save the currently scanned token - savedPush(yyextra, token, loc); - - // and replace it by a semicolon - *loc = yyextra->previousLoc; - loc->first_line = loc->last_line; - loc->first_column = loc->last_column; - loc->last_column++; - token = INSERTED_SEMI; - } - - // insert open brace? - else if (newline && loc->first_column > layoutColumn && - !endingToken(yyextra->previous) && !continuationToken(token)) - { - // fprintf(stderr,"insert { before: %c (0x%04x), top: %d\n", token, token, yyextra->savedTop); - // save the currently scanned token - savedPush(yyextra, token, loc); - - // and replace it by an open brace - *loc = yyextra->previousLoc; - loc->first_line = loc->last_line; - loc->first_column = loc->last_column; - loc->last_column++; - token = '{'; - } -#endif -#ifdef LINE_LAYOUT // simple semicolon insertion - if ((newline && endingToken(yyextra->previous) && !continueToken(token)) || - ((token == '}' || token == 0) && yyextra->previous != INSERTED_SEMI) ) // always insert before a '}' and eof - { - // save the currently scanned token - savedPush(yyextra,token,loc); - - // and replace it by a semicolon - *loc = yyextra->previousLoc; - loc->first_line = loc->last_line; - loc->first_column = loc->last_column; - loc->last_column++; - token = INSERTED_SEMI; - } -#endif - } // do layout? - } // not inserted semi - - // save token for the next run to previous - yyextra->previous = token; - yyextra->previousLoc = *loc; - - // debug output - if (yyextra->verbose) { - printToken(token,startState,scanner); - } - // return our token - return token; -} - - -/*---------------------------------------------------- - Initialize the extra state -----------------------------------------------------*/ -void initLoc( YYLTYPE* loc, int x ) -{ - loc->first_line = x; - loc->first_column = x; - loc->last_line = x; - loc->last_column = x; -} - -void initScanState( ExtraState* st ) -{ - st->tab = 8; - st->commentNesting = 0; - st->delimCount = 0; - - st->noLayout = false; -#ifdef INDENT_LAYOUT - st->layoutTop = 0; - st->layout[0] = 0; - initLoc(&st->commentLoc, 0); -#endif - -#ifdef CHECK_BALANCED - st->braceTop = -1; -#endif - - st->column = 1; - st->line = 1; - - st->previous = '{'; // so the layout context starts at the first token - initLoc(&st->previousLoc, 1); - - st->savedTop = -1; - - st->stringMax = 0; - st->stringLen = 0; - st->stringBuf = NULL; - - st->allocated = NULL; - - st->errorCount = 0; - st->verbose = 0; -} - -void doneScanState( ExtraState* st ) -{ - /* free temporary string literal buffer */ - if (st->stringBuf != NULL) { - free(st->stringBuf); - st->stringMax = 0; - st->stringLen = 0; - } - - /* free all memory allocated during scanning */ - alistFree(&st->allocated); - st->allocated = NULL; -} - -/*---------------------------------------------------- - Maintain the location -----------------------------------------------------*/ -YYLTYPE updateLoc( yyscan_t scanner ) -{ - EnableMacros(scanner); - YYLTYPE loc; - int line = loc.first_line = loc.last_line = yyextra->line; - int column = loc.first_column = loc.last_column = yyextra->column; - - int i; - for(i = 0; i < yyleng; i++) { - loc.last_line = line; - loc.last_column = column; - - if (yytext[i] == '\n') { - line++; - column=1; - } - else if (yytext[i] == '\t') { - int tab = yyextra->tab; - column = (((column+tab-1)/tab)*tab)+1; - loc.last_column = column-1; // adjust in case of tabs - } - else { - column++; - } - } - yyextra->line = line; - yyextra->column = column; - return loc; -} - -YYLTYPE currentLoc( const yyscan_t scanner ) -{ - EnableMacros(scanner); - /* save */ - int line = yyextra->line; - int column = yyextra->column; - /* update */ - YYLTYPE loc = updateLoc(scanner); - /* restore */ - yyextra->line = line; - yyextra->column = column; - return loc; -} - -/*---------------------------------------------------- - Comment nesting -----------------------------------------------------*/ -void commentNestingInc(yyscan_t scanner) -{ - EnableMacros(scanner); - yyextra->commentNesting++; -} - -int commentNestingDec(yyscan_t scanner) -{ - EnableMacros(scanner); - yyextra->commentNesting--; - return yyextra->commentNesting; -} - -/*---------------------------------------------------- - Raw string delimiter count -----------------------------------------------------*/ -void rawStringSetDelimCount(int count, yyscan_t scanner) -{ - EnableMacros(scanner); - yyextra->delimCount = count; -} - -int rawStringGetDelimCount(yyscan_t scanner) -{ - EnableMacros(scanner); - return yyextra->delimCount; -} - -/*---------------------------------------------------- - Numbers -----------------------------------------------------*/ -static void filter_underscore( char* buf, const char* src, size_t bufsize ) { - size_t i = 0; - while( i < bufsize - 1 && *src != 0) { - if (*src != '_') { - buf[i++] = *src; - } - src++; - } - buf[i] = 0; -} - -double numdouble( const char* s ) { - char buf[256]; - filter_underscore(buf,s,256); - return strtod(buf, NULL); -} - -long numlong( const char* s, int base ) { - char buf[256]; - filter_underscore(buf,s,256); - return strtol(buf, NULL, base ); -} - - -/*---------------------------------------------------- - string allocation -----------------------------------------------------*/ -char* stringDup( const char* s, yyscan_t scanner ) -{ - EnableMacros(scanner); - char* t = strdup(s); - if (t==NULL) { - yyerror(yylloc,scanner,"out of memory while scanning an identifier"); - exit(1); - } - alistAdd( &yyextra->allocated, t ); - return t; -} - -/*---------------------------------------------------- - identifier allocation -----------------------------------------------------*/ - -bool isLetter(char c) { - return ((c>='a' && c <= 'z') || (c>='A' && c<='Z') || c=='\0' || c==' '); -} -bool isDigit(char c) { - return (c>='0' && c <= '9'); -} - -bool wellformed( const char* s ) { - char prev = '\0'; - char next = '\0'; - const char* c; - for(c = s; *c != 0; c++) { - next = *(c+1); - if (*c=='-' && !((isLetter(prev) || isDigit(prev)) && isLetter(next))) return false; - if (*c=='(') return true; // qualified operator, or operator name - prev = *c; - } - return true; -} - -char* identifier( const char* s, yyscan_t scanner, bool wellformedCheck ) -{ - EnableMacros(scanner); - if (wellformedCheck && !wellformed(s)) yyerror(yylloc,scanner,"malformed identifier: a dash must be preceded and followed by a letter"); - return stringDup(s,scanner); -} - - -/*---------------------------------------------------- - String literals -----------------------------------------------------*/ -void stringStart( yyscan_t scanner ) -{ - EnableMacros(scanner); - yyextra->stringLen = 0; -} - -void stringAddStr( const char* s, yyscan_t scanner) { - while (*s) { - stringAdd( *s++, scanner); - } -} - -void stringAdd( unsigned int c, yyscan_t scanner) -{ - EnableMacros(scanner); - /* reallocate if necessary (always 5 more to accomodate any UTF-8 encoding + \0 char) */ - int len = yyextra->stringLen; - - if (len >= yyextra->stringMax) { - int newsize = (yyextra->stringMax==0 ? 128 : yyextra->stringMax*2); - char* buf = (char*)malloc(newsize+5); - if (buf==NULL) { - yyerror(yylloc,scanner,"out of memory while scanning a string"); - exit(1); - } - if (yyextra->stringBuf != NULL) { - strcpy(buf,yyextra->stringBuf); - free(yyextra->stringBuf); - } - yyextra->stringBuf = buf; - yyextra->stringMax = newsize; - } - /* add the new character to the buffer */ - /* encode to (modified) UTF-8 */ - if (c == 0) { - yyextra->stringBuf[len++] = 0xC0; - yyextra->stringBuf[len++] = 0x80; - } - else if (c <= 0x7F) { - yyextra->stringBuf[len++] = c; - } - else if (c <= 0x7FF) { - yyextra->stringBuf[len++] = (0xC0 | (c >> 6)); - yyextra->stringBuf[len++] = (0x80 | (c & 0x3F)); - } - else if (c <= 0xFFFF) { - yyextra->stringBuf[len++] = 0xE0 | (c >> 12); - yyextra->stringBuf[len++] = 0x80 | ((c >> 6) & 0x3F); - yyextra->stringBuf[len++] = 0x80 | (c & 0x3F); - } - else if (c <= 0x10FFFF) { - yyextra->stringBuf[len++] = 0xF0 | (c >> 18); - yyextra->stringBuf[len++] = 0x80 | ((c >> 12) & 0x3F); - yyextra->stringBuf[len++] = 0x80 | ((c >> 6) & 0x3F); - yyextra->stringBuf[len++] = 0x80 | (c & 0x3F); - } - else { - yyerror(yylloc,scanner,"illegal unicode character (0x%X)", c ); - } - /* always add a 0 at the end */ - yyextra->stringBuf[len] = 0; - yyextra->stringLen = len; -} - -char* stringEnd( yyscan_t scanner ) -{ - EnableMacros(scanner); - - char* buf = (char*)malloc((yyextra->stringLen+1)); - if (buf==NULL) { - yyerror(yylloc,scanner, "out of memory while scanning a string"); - exit(1); - } - alistAdd( &yyextra->allocated, buf); - if (yyextra->stringLen > 0) { - strcpy(buf,yyextra->stringBuf); - } - else { - buf[0] = 0; - } - return buf; -} - -/* Decode a UTF8 encoded character. - "len" should be 1 or larger, and gets set to the actual number of bytes read (<= len) - For an invalid UTF8 sequence, return the replacement character and set len to 0. */ -unsigned int utfDecode1( const char* buf, int* len ) -{ - unsigned int c = (unsigned char)(buf[0]); - if (c <= 0x7F && *len>=1) { - *len = 1; - return c; - } - else if (c >= 0xC2 && c <= 0xDF && *len>=2) { - unsigned int c1 = (unsigned char)(buf[1]); - *len = 2; - return (((c&0x1F)<<6) | (c1&0x3F)); - } - else if (c >= 0xE0 && c <= 0xEF && *len>=3) { - unsigned int c1 = (unsigned char)(buf[1]); - unsigned int c2 = (unsigned char)(buf[2]); - *len = 3; - return (((c&0x0F)<<12) | ((c1&0x3F)<<6) | (c2&0x3F)); - } - else if (c >= 0xF0 && c <= 0xF4 && *len>=4) { - unsigned int c1 = (unsigned char)(buf[1]); - unsigned int c2 = (unsigned char)(buf[2]); - unsigned int c3 = (unsigned char)(buf[3]); - *len = 4; - return (((c&0x07)<<18) | ((c1&0x3F)<<12) | ((c2&0x3F)<<6) | (c3&0x3F)); - } - else { - *len = 0; - return 0xFFFD; /* replacement character */ - } -} - -/* Decode a UTF8 encoded character */ -unsigned int utfDecode( const char* buf, int len, yyscan_t scanner ) -{ - int scanned = len; - unsigned int c = utfDecode1( buf, &scanned ); - if (scanned != len || len == 0) { - YYLTYPE loc = currentLoc(scanner); - yyerror( &loc, scanner, "illegal UTF-8 character sequence encountered: %s", buf ); - } - return c; -} - - -/*---------------------------------------------------- - Errors -----------------------------------------------------*/ -void illegal(char* s, yyscan_t scanner ) -{ - YYLTYPE loc = currentLoc(scanner); - yyerror(&loc,scanner, s ); -} - -void illegalchar( char c, char* s, yyscan_t scanner ) -{ - YYLTYPE loc = currentLoc(scanner); - const char* schar = showChar(c,scanner); - if (s == NULL && c == '\t') { - s = "(replace tabs with spaces)"; - } - if (s == NULL || strlen(s) == 0) { - yyerror(&loc,scanner, "illegal character '%s'", schar); - } - else { - yyerror(&loc,scanner, "illegal character '%s' %s", schar, s ); - } -} - -void yyerror( YYLTYPE* loc, yyscan_t scanner, char* s, ... ) -{ - EnableMacros(scanner); - va_list ap; - va_start(ap, s); - - // print location - if (loc->first_line >= 1) { - fprintf(stderr,"(%d,%2d)-(%d,%2d): ", loc->first_line, loc->first_column, - loc->last_line, loc->last_column); - } - - // print message - vfprintf(stderr, s, ap); - fprintf(stderr, "\n"); - - // check error count - yyextra->errorCount++; - if (yyextra->errorCount >= errorMax) { - fprintf(stderr, "maximum number of errors reached.\n" ); - exit(1); - } -} - -/*---------------------------------------------------- - Main -----------------------------------------------------*/ -int yyparse( yyscan_t scanner ); - -static bool isPrefix( const char* pre, const char* s ) { - if (pre==NULL) return true; - if (s==NULL) return (pre[0] == 0); - while (pre[0] != 0) { - if (pre[0] != s[0]) return false; - pre++; - s++; - } - return true; -} - -int main( int argc, char** argv ) -{ - /* initialize */ - yyscan_t scanner; - yylex_init( &scanner ); - EnableMacros(scanner); - - ExtraState st; - initScanState( &st ); - yyset_extra( &st, scanner ); - - /* read argument and parse */ - int arg = 1; - while (arg < argc) { - if (strcmp( argv[arg], "--nosemi") == 0) { - st.noLayout = true; - } - else if (strcmp( argv[arg], "--verbose") == 0 || strcmp(argv[arg], "-v") == 0) { - st.verbose++; - } - else if (isPrefix( "--tab=", argv[arg])) { - st.tab = atoi(argv[arg]+6); - } - else if (strcmp( argv[arg], "--help") == 0) { - yyin=NULL; - break; - } - else if (argv[arg][0] == '-') { - fprintf(stderr,"unrecognized option: %s\n", argv[arg] ); - exit(1); - } - else if (yyin != NULL) { - fprintf(stderr,"too many file parameters: %s\n", argv[arg]); - exit(1); - } - else { - yyin = fopen(argv[arg], "r"); - if (!yyin) { - fprintf(stderr,"couldn't open file: %s\n", argv[arg]); - exit(1); - } - else { - // skip UTF-8 BOM ? - bool skippedBOM = (fgetc(yyin)==0xEF && fgetc(yyin)==0xBB && fgetc(yyin)==0xBF); - if (!skippedBOM) { - fseek(yyin,0,SEEK_SET); // rewind - } - else if (st.verbose) { - fprintf(stderr,"skipped BOM\n"); - } - } - } - arg++; - } - - if (yyin==NULL) { - printf("usage: koka-parser [--nosemi|--verbose|-v] \n"); - } - else { - yyparse(scanner); - - /* destroy */ - int errorCount = st.errorCount; - int lineCount = st.line; - yylex_destroy(scanner); - doneScanState(&st); - - /* final message */ - if (errorCount == 0) { - printf("Success! (%i lines parsed)\n", lineCount); - return 0; - } - else { - printf("Failure (%i errors encountered)\n", errorCount); - return 1; - } - } -} - - - - -/*---------------------------------------------------- - Nicely print a token to stderr -----------------------------------------------------*/ -char* showChar( unsigned int c, yyscan_t scanner ) -{ - char buf[11]; /* 11 = format of \U%06X + zero byte */ - if (c >= ' ' && c <= '~' && c != '\\' && c != '\'' && c != '\"') { - sprintf(buf,"%c",c); - } - else if (c <= 0xFF) { - if (c=='\t') sprintf(buf,"\\t"); - else if (c=='\n') sprintf(buf,"\\n"); - else if (c=='\r') sprintf(buf,"\\r"); - else if (c=='\'') sprintf(buf,"\\'"); - else if (c=='\"') sprintf(buf,"\\\""); - else sprintf(buf,"\\x%02X",c); - } - else if (c <= 0xFFFF) { - sprintf(buf,"\\u%04X",c); - } - else if (c <= 0xFFFFFF) { - sprintf(buf,"\\U%06X",c); - } - else { - sprintf(buf,"\\X%08X",c); - } - return stringDup(buf,scanner); -} - -char* showString( const char* s, yyscan_t scanner ) -{ - if (s==NULL) return ""; - - const int max = 60; - char buf[max + 10 + 3 + 1]; // max + maximal character width + " .." 0 - int dest = 0; - int src = 0; - int slen = strlen(s); - buf[dest++] = '"'; - while (dest < max && s[src] != 0) { - int len = slen - src; - unsigned int c = utfDecode1(s + src,&len); - if (len==0) src++; - else src += len; - const char* schar = showChar(c,scanner); - strcpy(buf+dest,schar); - dest += strlen(schar); - } - if (s[src] == 0) { - buf[dest++] = '"'; - } - else { - buf[dest++] = ' '; - buf[dest++] = '.'; - buf[dest++] = '.'; - } - buf[dest] = 0; - return stringDup(buf,scanner); -} - -void printToken( int token, int state, yyscan_t scanner ) -{ - EnableMacros(scanner); - - fprintf(stderr,"(%2d,%2d)-(%2d,%2d) 0x%04x <%d> [", yylloc->first_line, yylloc->first_column, yylloc->last_line, yylloc->last_column, token, state ); - for(int i = 0; i <= yyextra->layoutTop; i++) { - fprintf(stderr, "%d%s", yyextra->layout[i], (i==yyextra->layoutTop ? "" : ",") ); - } - fprintf(stderr, "]: "); - switch(token) { - case ID: fprintf(stderr,"ID = '%s'", yylval->Id); break; - case CONID: fprintf(stderr,"CONID = '%s'", yylval->Id); break; - case OP: fprintf(stderr,"OP = '%s'", yylval->Id); break; - case QID: fprintf(stderr,"QID = '%s'", yylval->Id); break; - case QCONID: fprintf(stderr,"QCONID= '%s'", yylval->Id); break; - // case QOP: fprintf(stderr,"QOP = '%s'", yylval->Id); break; - case INT: fprintf(stderr,"INT = '%lu'", yylval->Int); break; - case FLOAT: fprintf(stderr,"FLOAT = '%g'", yylval->Float); break; - case CHAR: fprintf(stderr,"CHAR = '%s'", showChar(yylval->Char,scanner)); break; - case INSERTED_SEMI: fprintf(stderr,"; = (inserted)"); break; - case STRING: fprintf(stderr,"STRING(%zu) = %s", strlen(yylval->String), showString(yylval->String,scanner)); break; - default: { - if (token >= ' ' && token <= '~') - fprintf(stderr,"%c", token); - else if (token < ' ') - fprintf(stderr,"0x%x", token ); - else - fprintf(stderr,"%s", yytext); - } - } - fprintf(stderr,"\n"); -} - - - -/*--------------------------------------------------------- - The allocation list - Used to free memory allocted of identifiers and - string literals. ----------------------------------------------------------*/ -struct _allocList { - struct _allocList* next; - void* mem; -}; - -void alistAdd( allocList* list, void* p ) -{ - if (p == NULL) return; - - allocList head = (allocList)malloc(sizeof(struct _allocList)); - if (head == NULL) return; - - head->mem = p; - head->next = *list; - *list = head; -} - -void alistFree( allocList* list ) -{ - allocList head = *list; - - while (head != NULL) { - allocList next = head->next; - if (head->mem != NULL) { - free(head->mem); - } - free(head); - head = next; - } -} +/* Copyright 2012-2021, Microsoft Research, Daan Leijen + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. +*/ +/* Use the "Yash" extension in vscode for nice syntax highlighting. + Requires at least Flex 2.5.37; you can get a version for windows from + https://sourceforge.net/projects/winflexbison +*/ +%option 8bit noyywrap bison-bridge bison-locations reentrant + +/* Exclusive Lexer states */ +%x comment +%x linecomment +%x string +%x rawstring + +%{ +#define CHECK_BALANCED // check balanced parenthesis +#define INSERT_CLOSE_BRACE +#define INSERT_OPEN_BRACE +#define INDENT_LAYOUT // use full layout rule based on nested indentation +#undef LINE_LAYOUT // use simple layout based on line ending token + +/* Standard types and includes */ +typedef int bool; +#define true (1==1) +#define false (!true) + +#include "stdlib.h" +#include "string.h" +#include "stdarg.h" +#include "assert.h" +#include "parser.tab.h" + +/* The extra scanner state */ +#define YY_EXTRA_TYPE struct _ExtraState* + +/* Errors */ +void yyerror( YYLTYPE* loc, yyscan_t scanner, char* s, ... ); +void illegal( char* s, yyscan_t scanner ); +void illegalchar( char c, char* s, yyscan_t scanner ); + +/* Comments */ +void commentNestingInc(yyscan_t scanner); +int commentNestingDec(yyscan_t scanner); + +/* Numbers */ +double numdouble( const char* s ); +long numlong( const char* s, int base ); + +/* Allocation of identifiers and string literals */ +char* identifier( const char* s, yyscan_t scanner, bool wellformedCheck ); +char* stringDup( const char* s, yyscan_t scanner ); +void stringStart( yyscan_t scanner ); +void stringAdd( unsigned int c, yyscan_t scanner); +void stringAddStr( const char* s, yyscan_t scanner ); +char* stringEnd( yyscan_t scanner ); +unsigned int utfDecode( const char* buf, int len, yyscan_t scanner ); + +/* Raw string delimiter length */ +void rawStringSetDelimCount( int count, yyscan_t scanner ); +int rawStringGetDelimCount( yyscan_t scanner ); + +/* Character escape codes */ +char escapeToChar( char esc, yyscan_t scanner ) +{ + switch(esc) { + case 'n' : return '\n'; + case 'r' : return '\r'; + case 't' : return '\t'; + case '\\': return '\\'; + case '"' : return '"'; + case '\'': return '\''; + default : illegalchar(esc,"escape code",scanner); + return esc; + } +} + +%} + + /* Character classes */ + +Symbols {Symbol}+|[/] +Symbol [\$\%\&\*\+\@!\\\^\~=\.\-\:\?\|\<\>] +AngleBar [\<\>\|] +Angle [\<\>] +Sign [\-]? + +ConId {Upper}{IdChar}*{Final}* +Id {Lower}{IdChar}*{Final}* +IdChar {Letter}|{Digit}|[_\-] + +HexEsc x{Hex}{Hex}|u{Hex}{Hex}{Hex}{Hex}|U{Hex}{Hex}{Hex}{Hex}{Hex}{Hex} +CharEsc [nrt\\\"\'] +/* for editor highlighting " */ + +LineChar {GraphicLine}|{Utf8} +BlockChar {GraphicBlock}|{Utf8} + +Decimal 0|[1-9](_?{Digits})? +HexaDecimal 0[xX]{HexDigits} + +Digits {Digit}+{DigitSep}* +HexDigits {Hex}+{HexSep}* + +DigitSep _{Digit}+ +HexSep _{Hex}+ + +Letter {Lower}|{Upper} +Upper [A-Z] +Lower [a-z] +Digit [0-9] +Hex [0-9a-fA-F] +Space [ \t] +Newline [\r]?[\n] +Final [\'] +/* for editor highlighting ' */ + +GraphicChar [ \x21-\x26\x28-\[\]-\x7E] +GraphicStr [ \x21\x23-\[\]-\x7E] +GraphicRaw [\t \n\r\x21\x23-\x7E] +GraphicLine [\t \x21-\x7E] +GraphicBlock [\t \x21-\)\+-\.0-\x7E] + + /* Valid UTF-8 sequences. Based on http://www.w3.org/2005/03/23-lex-U + Added \xC0\x80 as a valid sequence to represent 0 (also called 'modified' utf-8) + */ +UC [\x80-\xBF] +U2 [\xC2-\xDF]{UC} +U3 [\xE0][\xA0-\xBF]{UC}|[\xE1-\xEC]{UC}{UC}|[\xED][\x80-\x9F]{UC}|[\xEE-\xEF]{UC}{UC} +U4 [\xF0][\x90-\xBF]{UC}{UC}|[\xF1-\xF3]{UC}{UC}{UC}|[\xF4][\x80-\x8F]{UC}{UC} +Utf8 {U2}|{U3}|{U4} + + +%% + + /* -------- INITIAL ------------- */ + + /* keywords */ +infix { return INFIX; } +infixl { return INFIXL; } +infixr { return INFIXR; } + +type { return TYPE; } +alias { return ALIAS; } +struct { return STRUCT; } +effect { return EFFECT; } + +forall { return FORALL; } +exists { return EXISTS; } +some { return SOME; } + +abstract { return ABSTRACT; } +extern { return EXTERN; } + +fun { return FUN; } +fn { return FN; } +val { return VAL; } +var { return VAR; } +con { return CON; } + +if { return IF;} +then { return THEN; } +else { return ELSE;} +elif { return ELIF;} +with { return WITH; } +in { return IN; } +match { return MATCH;} +return { return RETURN;} + +module { return MODULE;} +import { return IMPORT;} +pub { return PUB;} +as { return AS;} + +handle { return HANDLE; } +handler { return HANDLER; } +ctl { return CTL; } +final { return FINAL; } +raw { return RAW; } +mask { return MASK; } +override { return OVERRIDE; } +named { return NAMED; } + +rec { return ID_REC; } +co { return ID_CO; } +open { return ID_OPEN; } +extend { return ID_EXTEND; } +linear { return ID_LINEAR; } +value { return ID_VALUE; } +reference { return ID_REFERENCE; } + +inline { return ID_INLINE; } +noinline { return ID_NOINLINE;} +scoped { return ID_SCOPED; } +behind { return ID_BEHIND; } +initially { return ID_INITIALLY; } +finally { return ID_FINALLY; } + + /* unused reserved identifiers */ +interface { return IFACE; } +break { return BREAK; } +continue { return CONTINUE; } +unsafe { return UNSAFE; } + + /* reserved operators */ +: { return ':'; } += { return '='; } +\. { return '.'; } +\-\> { return RARROW; } +\<\- { return LARROW; } + + /* special operators and identifiers (not reserved but have special meaning in certain contexts) */ +:= { return ASSIGN; } +:: { return DCOLON; } +\| { return '|'; } +\< { return '<'; } +\> { return '>'; } +! { return '!'; } +\^ { return '^'; } +~ { return '~'; } + +file { return ID_FILE; } +cs { return ID_CS; } +js { return ID_JS; } +c { return ID_C; } + + /* Special symbols (cannot be an operator) */ +\) { return ')'; } +\( { return '('; } +\{ { return '{'; } +\} { return '}'; } +\[ { return '['; } +\] { return ']'; } +; { return ';'; } +, { return ','; } +` { return '`'; } + + /* Comments */ +\/\/ { BEGIN(linecomment); yymore(); } +\/\* { BEGIN(comment); commentNestingInc(yyscanner); yyless(2); yymore(); } + + /* Type operators: these are all illegal operators and should be parsed as single characters + For example, in types, we can have sequences like "<|>" where "<<", ">|<", and ">>" + should not be parsed as operator tokens. */ +\|\| { yylval->Id = identifier(yytext,yyscanner,false); return OP; } +{AngleBar}{AngleBar}+ { yyless(1); return yytext[0]; } + + /* Numbers */ +{Sign}{Decimal}\.{Digits}[eE][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } +{Sign}{Decimal}[eE][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } +{Sign}{Decimal}\.{Digits} { yylval->Float = numdouble(yytext); return FLOAT; } + +{Sign}{HexaDecimal}\.{HexDigits}[pP][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } +{Sign}{HexaDecimal}[pP][\-\+]?{Digit}+ { yylval->Float = numdouble(yytext); return FLOAT; } +{Sign}{HexaDecimal}\.{HexDigits} { yylval->Float = numdouble(yytext); return FLOAT; } + +{Sign}{HexaDecimal} { yylval->Int = numlong(yytext+2,16); return INT; } +{Sign}{Decimal} { yylval->Int = numlong(yytext,10); return INT; } + + + /* Identifiers and operators */ +({Id}\/)+{ConId} { yylval->Id = identifier(yytext,yyscanner,true); return QCONID; } +({Id}\/)+{Id} { yylval->Id = identifier(yytext,yyscanner,true); return QID; } +({Id}\/)+\({Symbols}\) { yylval->Id = identifier(yytext,yyscanner,true); return QIDOP; } + +{ConId} { yylval->Id = identifier(yytext,yyscanner,true); return CONID; } +{Id} { yylval->Id = identifier(yytext,yyscanner,true); return ID; } +\({Symbols}\) { yylval->Id = identifier(yytext,yyscanner,false); return IDOP; } +{Symbols} { yylval->Id = identifier(yytext,yyscanner,false); return OP; } +_{IdChar}* { yylval->Id = identifier(yytext,yyscanner,true); return WILDCARD; } + + /* Character literals */ +\'{GraphicChar}\' { yylval->Char = yytext[1]; return CHAR; } +\'\\{HexEsc}\' { yylval->Char = strtol(yytext+3,NULL,16); return CHAR; } +\'\\{CharEsc}\' { yylval->Char = escapeToChar(yytext[2],yyscanner); return CHAR; } +\'{Utf8}\' { yylval->Char = utfDecode(yytext+1,yyleng-2,yyscanner); return CHAR; } +\'.\' { illegalchar(yytext[1],"character literal",yyscanner); + yylval->Char = ' '; + return CHAR; + } +\'. { illegal("illegal character literal",yyscanner); // ' + yylval->Char = ' '; + return CHAR; + } + + /* String literal start */ +\" { BEGIN(string); // " + stringStart(yyscanner); + yymore(); + } + + /* Raw string literal start */ +r#*\" { BEGIN(rawstring); /* " for editor highlighting */ + rawStringSetDelimCount(yyleng-1,yyscanner); + stringStart(yyscanner); + yyless(yyleng); + yymore(); + } + + /* White space */ +{Space}+ { return LEX_WHITE; } +{Newline} { return LEX_WHITE; } +. { illegalchar(yytext[yyleng-1],NULL,yyscanner); + return LEX_WHITE; + } + + /* --------- Raw string literals --------- */ +\"#* { int count = rawStringGetDelimCount(yyscanner); + int scanned = yyleng - YY_MORE_ADJ; + if (count > scanned) { + // keep going + stringAddStr(yytext + YY_MORE_ADJ, yyscanner ); + yymore(); + } + else { + // end of string + if (count < scanned) illegalchar('#',"raw string terminated with too many '#' characters", yyscanner); + BEGIN(INITIAL); + yylval->String = stringEnd(yyscanner); + return STRING; + } + } +{GraphicRaw}+ { stringAddStr(yytext + YY_MORE_ADJ, yyscanner ); + yymore(); + } +{Utf8} { stringAdd(utfDecode(yytext+YY_MORE_ADJ,yyleng-YY_MORE_ADJ,yyscanner), yyscanner); yymore(); } +. { illegalchar(yytext[yyleng-1],"raw string", yyscanner); + yymore(); + } + + /* --------- String literals --------- */ +\" { BEGIN(INITIAL); // " + yylval->String = stringEnd(yyscanner); + return STRING; + } +{GraphicStr}+ { char* p = yytext + YY_MORE_ADJ; + while (*p) { + stringAdd( *p++, yyscanner); + } + yymore(); + } +\\{HexEsc} { stringAdd(strtol(yytext+2+YY_MORE_ADJ,NULL,16),yyscanner); yymore(); } +\\{CharEsc} { stringAdd(escapeToChar(yytext[1+YY_MORE_ADJ],yyscanner),yyscanner); yymore(); } +{Utf8} { stringAdd(utfDecode(yytext+YY_MORE_ADJ,yyleng-YY_MORE_ADJ,yyscanner),yyscanner); yymore(); } + +{Newline} { BEGIN(INITIAL); + illegal( "illegal newline ends string", yyscanner ); + yylval->String = stringEnd(yyscanner); + return STRING; + } +. { illegalchar(yytext[yyleng-1],"string", yyscanner); + yymore(); + } + + + /* ---------- Comments ------------ " */ +{BlockChar}+ { yymore(); } +\/\* { commentNestingInc(yyscanner); yymore(); } +\*\/ { if (commentNestingDec(yyscanner) == 0) { + BEGIN(INITIAL); + return LEX_COMMENT; + } + else yymore(); + } +\* { yymore(); } +\/ { yymore(); } +{Newline} { return LEX_COMMENT; } +. { illegalchar(yytext[yyleng-1], "comment", yyscanner); + yymore(); + } + +{LineChar}+ { yymore(); } +{Newline} { BEGIN(INITIAL); return LEX_COMMENT; } +. { illegalchar( yytext[yyleng-1], "line comment", yyscanner ); + yymore(); + } + +%% + +/* Enable the use of regular Flex macros (like yyextra) inside user defined functions */ +#define EnableMacros(s) yyget_extra(s); struct yyguts_t* yyg = (struct yyguts_t*)(s); + + +/* Keep a list of allocated memory + in order to free all allocated identifiers and string literals afterwards*/ +typedef struct _allocList* allocList; + +void alistAdd ( allocList* list, void* p ); +void alistFree( allocList* list ); + +// show character or string +char* showChar( unsigned int c, yyscan_t scanner ); +char* showString( const char* s, yyscan_t scanner ); + +/*--------------------------------------------------------- + The extra state + This is used to maintain: + - nesting level of comments + - the precise position + - the previous token + - the layout stack for semicolon insertion + - the saved token when a semicolon was inserted + - a buffer for string literals + - an allocation list to free allocated identifiers and string literals. + - the number of errors +---------------------------------------------------------*/ +#define errorMax 1 // 25 +#define layoutMax 255 /* Limit maximal layout stack to 255 for simplicity */ +#define braceMax 255 /* maximal nesting depth of parenthesis */ +#define Token int +#define savedMax 255 + +typedef struct _ExtraState { + /* nested comments */ + int commentNesting; + + /* raw string delimiter count */ + int delimCount; + + /* precise position */ + int column; + int line; + + /* layout stack */ + bool noLayout; // apply the layout rule and insert semicolons? */ +#ifdef INDENT_LAYOUT + int layoutTop; + int layout[layoutMax]; + + /* location of the last seen comment -- used to prevent comments in indentation */ + YYLTYPE commentLoc; +#endif + +#ifdef CHECK_BALANCED + /* balanced braces */ + int braceTop; + Token braces[braceMax]; + YYLTYPE bracesLoc[braceMax]; +#endif + + /* the previous non-white token and its location */ + Token previous; + YYLTYPE previousLoc; + + /* the saved token and location: used to insert semicolons */ + int savedTop; + Token savedToken[savedMax]; + YYLTYPE savedLoc[savedMax]; + + /* temporary string buffer for string literals */ + int stringMax; + int stringLen; + char* stringBuf; + + /* list of storage for yylval allocations */ + allocList allocated; + + /* number of calls to yyerror */ + int errorCount; + + /* be verbose */ + int verbose; + + /* tab size used for error reporting */ + int tab; + +} ExtraState; + +/* Forward declarations on the state */ +YYLTYPE updateLoc( yyscan_t scanner ); /* update the location after yylex returns */ +void printToken( int token, int state, yyscan_t scanner ); /* print a token for debugging purposes */ + +/*---------------------------------------------------- + For semi-colon insertion, we look at the tokens that + end statements, and ones that continue a statement +----------------------------------------------------*/ +static int find( Token tokens[], Token token ) +{ + int i = 0; + while (tokens[i] != 0) { + if (tokens[i] == token) return i; + i++; + } + return -1; +} + +static bool contains( Token tokens[], Token token ) { + return (find(tokens,token) >= 0); +} + +static Token appTokens[] = { ')', ']', '>', ID, CONID, IDOP, QID, QCONID, QIDOP, 0 }; + +static bool isAppToken( Token token ) { + return contains(appTokens, token ); +} + + +#ifdef INDENT_LAYOUT + static Token continuationTokens[] = { ')', '>', ']', ',', '{', '}', '|', ':', '.', '=', ASSIGN, OP, THEN, ELSE, ELIF, RARROW, LARROW, 0 }; + // { THEN, ELSE, ELIF, ')', ']', '{', 0 }; + + static bool continuationToken( Token token ) { + return contains(continuationTokens, token ); + } +#endif + + +#ifdef INSERT_OPEN_BRACE + static Token endingTokens[] = { '(', '<', '[', ',', '{', '.', OP, 0 }; + + bool endingToken( Token token ) { + return contains(endingTokens,token); + } +#endif + +#ifdef LINE_LAYOUT + static Token endingTokens[] = { ID, CONID, IDOP, QIDOP, QID, QCONID, INT, FLOAT, STRING, CHAR, ')', ']', '}', '>', 0 }; + static Token continueTokens[] = { THEN, ELSE, ELIF, '=', '{', '}', ')', ']', '>', 0 }; + + bool endingToken( Token token ) { + return contains(endingTokens,token); + } + + bool continueToken( Token token ) { + return contains(continueTokens,token); + } +#endif + +#ifdef CHECK_BALANCED + static Token closeTokens[] = { ')', '}', ']', /* ')', ']',*/ 0 }; + static Token openTokens[] = { '(', '{', '[', /* APP, IDX,*/ 0 }; + + Token isCloseBrace( Token token ) { + int i = find(closeTokens,token); + return (i >= 0 ? openTokens[i] : -1); + } + + Token isOpenBrace( Token token ) { + int i = find(openTokens,token); + return (i >= 0 ? closeTokens[i] : -1); + } +#endif + + +static void savedPush( YY_EXTRA_TYPE extra, Token token, YYLTYPE* loc ) { + assert(extra->savedTop < savedMax); + extra->savedTop++; + extra->savedToken[extra->savedTop] = token; + extra->savedLoc[extra->savedTop] = *loc; + // fprintf(stderr, "save token (%d,%d): %c (0x%04x) (new top: %d)\n", loc->first_line, loc->first_column, token, token, extra->savedTop ); +} + +static void savedPop( YY_EXTRA_TYPE extra, Token* token, YYLTYPE* loc ) { + assert(extra->savedTop >= 0); + *token = extra->savedToken[extra->savedTop]; + *loc = extra->savedLoc[extra->savedTop]; + extra->savedTop--; + // fprintf(stderr, "restore from saved (%d,%d): %c (0x%04x) (new top: %d)\n", loc->first_line, loc->first_column, *token, *token, extra->savedTop ); +} + +/*---------------------------------------------------- + Main lexical analysis routine 'mylex' +----------------------------------------------------*/ + +Token mylex( YYSTYPE* lval, YYLTYPE* loc, yyscan_t scanner) +{ + EnableMacros(scanner); + Token token; + int startState = YYSTATE; + + // do we have a saved token? + if (yyextra->savedTop >= 0) { + // fprintf(stderr,"have saved: %d\n", yyextra->savedTop); + savedPop( yyextra, &token, loc ); + } + + // if not, scan ahead + else { + token = yylex( lval, loc, scanner ); + *loc = updateLoc( scanner ); + + /* + // this is to avoid needing semicolons + if (token=='(' && isAppToken(yyextra->previous)) token = APP; + if (token=='[' && isAppToken(yyextra->previous)) token = IDX; + */ + + // skip whitespace + while (token == LEX_WHITE || token == LEX_COMMENT) { +#ifdef INDENT_LAYOUT + // save last comment location (to check later if it was not part of indentation) + if (token == LEX_COMMENT) { + yyextra->commentLoc = *loc; + } +#endif + // scan again + token = yylex( lval, loc, scanner ); + *loc = updateLoc(scanner); + } + } + + + + if (yyextra->previous != INSERTED_SEMI) { +#ifdef CHECK_BALANCED + // check balanced braces + Token closeBrace = isOpenBrace(token); + //fprintf(stderr,"scan: %d, %d, (%d,%d)\n", token, closeBrace, loc->first_line, loc->first_column); + if (closeBrace>=0) { + if (yyextra->braceTop >= (braceMax-1)) { + yyerror(loc,scanner, "maximal nesting level of braces reached"); + } + else { + // push the close brace + yyextra->braceTop++; + yyextra->braces[yyextra->braceTop] = closeBrace; + yyextra->bracesLoc[yyextra->braceTop] = *loc; + } + } + else if (isCloseBrace(token) >= 0) { + // check if the close brace matches the context + if (yyextra->braceTop < 0) { + yyerror(loc, scanner, "unbalanced braces: '%c' is not opened", token); + } + else if (yyextra->braces[yyextra->braceTop] != token) { + YYLTYPE openLoc = yyextra->bracesLoc[yyextra->braceTop]; + // try to pop to nearest open brace; otherwise don't pop at all + int top = yyextra->braceTop-1; + while( top >= 0 && yyextra->braces[top] != token) top--; + if (top >= 0) { + // there is a matching open brace on the stack + yyerror(&openLoc, scanner, "unbalanced braces: '%c' is not closed", isCloseBrace(yyextra->braces[yyextra->braceTop]) ); + yyextra->braceTop = top-1; // pop to matching one + } + else { + // no matching brace + yyerror(loc, scanner, "unbalanced braces: '%c' is not opened", token ); //, yyextra->braces[yyextra->braceTop],openLoc.first_line,openLoc.first_column); + } + } + else { + // pop + yyextra->braceTop--; + } + } +#endif + + // Do layout ? + if (!yyextra->noLayout) + { + bool newline = (yyextra->previousLoc.last_line < loc->first_line); + +#ifdef INDENT_LAYOUT + // set a new layout context? + if (yyextra->previous == '{') { + if (token != '}' && loc->first_column <= yyextra->layout[yyextra->layoutTop]) { + yyerror(loc,scanner,"illegal layout start; the line must be indented at least as much as its enclosing layout context (column %d)", yyextra->layout[yyextra->layoutTop-1]); + } + if (yyextra->verbose) { + fprintf(stderr," layout start: %d\n", loc->first_column); + } + + if (yyextra->layoutTop == layoutMax) { + yyerror(loc,scanner,"maximal layout nesting level reached!"); + } + else { + yyextra->layoutTop++; + yyextra->layout[yyextra->layoutTop] = loc->first_column; + } + } + + // pop from the layout stack? + if (token == '}') { + if (yyextra->layoutTop <= 1) { + yyerror(loc,scanner,"unexpected closing brace"); + } + else { + if (yyextra->verbose) { + fprintf( stderr, " layout end %d\n", yyextra->layout[yyextra->layoutTop] ); + } + yyextra->layoutTop--; + } + } + + int layoutColumn = yyextra->layout[yyextra->layoutTop]; + + if (newline) { + // check comment in indentation + if (yyextra->commentLoc.last_line == loc->first_line) { + yyerror(&yyextra->commentLoc,scanner,"comments are not allowed in indentation; rewrite by putting the comment on its own line or at the end of the line"); + } + #ifndef INSERT_CLOSE_BRACE + // check layout + if (loc->first_column < layoutColumn) { + yyerror(loc,scanner,"illegal layout: the line must be indented at least as much as its enclosing layout context (column %d)", layoutColumn); + } + #else + if (token != '}' && loc->first_column < layoutColumn && yyextra->layoutTop > 1) { + // fprintf(stderr,"line (%d,%d): insert }, layout col: %d\n", loc->first_line, loc->first_column, yyextra->layoutTop); + // pop layout column + yyextra->layoutTop--; + layoutColumn = yyextra->layout[yyextra->layoutTop]; + + // save the currently scanned token + savedPush(yyextra, token, loc); + + // and replace it by a closing brace + *loc = yyextra->previousLoc; + loc->first_line = loc->last_line; + loc->first_column = loc->last_column; + loc->last_column++; + token = '}'; + } + #endif + } + + // insert a semi colon? + if ( // yyextra->previous != INSERTED_SEMI && + ((newline && loc->first_column == layoutColumn && !continuationToken(token)) + || token == '}' || token == 0)) + { + // fprintf(stderr,"insert semi before: %c (0x%04x), top: %d\n", token, token, yyextra->savedTop); + // save the currently scanned token + savedPush(yyextra, token, loc); + + // and replace it by a semicolon + *loc = yyextra->previousLoc; + loc->first_line = loc->last_line; + loc->first_column = loc->last_column; + loc->last_column++; + token = INSERTED_SEMI; + } + + // insert open brace? + else if (newline && loc->first_column > layoutColumn && + !endingToken(yyextra->previous) && !continuationToken(token)) + { + // fprintf(stderr,"insert { before: %c (0x%04x), top: %d\n", token, token, yyextra->savedTop); + // save the currently scanned token + savedPush(yyextra, token, loc); + + // and replace it by an open brace + *loc = yyextra->previousLoc; + loc->first_line = loc->last_line; + loc->first_column = loc->last_column; + loc->last_column++; + token = '{'; + } +#endif +#ifdef LINE_LAYOUT // simple semicolon insertion + if ((newline && endingToken(yyextra->previous) && !continueToken(token)) || + ((token == '}' || token == 0) && yyextra->previous != INSERTED_SEMI) ) // always insert before a '}' and eof + { + // save the currently scanned token + savedPush(yyextra,token,loc); + + // and replace it by a semicolon + *loc = yyextra->previousLoc; + loc->first_line = loc->last_line; + loc->first_column = loc->last_column; + loc->last_column++; + token = INSERTED_SEMI; + } +#endif + } // do layout? + } // not inserted semi + + // save token for the next run to previous + yyextra->previous = token; + yyextra->previousLoc = *loc; + + // debug output + if (yyextra->verbose) { + printToken(token,startState,scanner); + } + // return our token + return token; +} + + +/*---------------------------------------------------- + Initialize the extra state +----------------------------------------------------*/ +void initLoc( YYLTYPE* loc, int x ) +{ + loc->first_line = x; + loc->first_column = x; + loc->last_line = x; + loc->last_column = x; +} + +void initScanState( ExtraState* st ) +{ + st->tab = 8; + st->commentNesting = 0; + st->delimCount = 0; + + st->noLayout = false; +#ifdef INDENT_LAYOUT + st->layoutTop = 0; + st->layout[0] = 0; + initLoc(&st->commentLoc, 0); +#endif + +#ifdef CHECK_BALANCED + st->braceTop = -1; +#endif + + st->column = 1; + st->line = 1; + + st->previous = '{'; // so the layout context starts at the first token + initLoc(&st->previousLoc, 1); + + st->savedTop = -1; + + st->stringMax = 0; + st->stringLen = 0; + st->stringBuf = NULL; + + st->allocated = NULL; + + st->errorCount = 0; + st->verbose = 0; +} + +void doneScanState( ExtraState* st ) +{ + /* free temporary string literal buffer */ + if (st->stringBuf != NULL) { + free(st->stringBuf); + st->stringMax = 0; + st->stringLen = 0; + } + + /* free all memory allocated during scanning */ + alistFree(&st->allocated); + st->allocated = NULL; +} + +/*---------------------------------------------------- + Maintain the location +----------------------------------------------------*/ +YYLTYPE updateLoc( yyscan_t scanner ) +{ + EnableMacros(scanner); + YYLTYPE loc; + int line = loc.first_line = loc.last_line = yyextra->line; + int column = loc.first_column = loc.last_column = yyextra->column; + + int i; + for(i = 0; i < yyleng; i++) { + loc.last_line = line; + loc.last_column = column; + + if (yytext[i] == '\n') { + line++; + column=1; + } + else if (yytext[i] == '\t') { + int tab = yyextra->tab; + column = (((column+tab-1)/tab)*tab)+1; + loc.last_column = column-1; // adjust in case of tabs + } + else { + column++; + } + } + yyextra->line = line; + yyextra->column = column; + return loc; +} + +YYLTYPE currentLoc( const yyscan_t scanner ) +{ + EnableMacros(scanner); + /* save */ + int line = yyextra->line; + int column = yyextra->column; + /* update */ + YYLTYPE loc = updateLoc(scanner); + /* restore */ + yyextra->line = line; + yyextra->column = column; + return loc; +} + +/*---------------------------------------------------- + Comment nesting +----------------------------------------------------*/ +void commentNestingInc(yyscan_t scanner) +{ + EnableMacros(scanner); + yyextra->commentNesting++; +} + +int commentNestingDec(yyscan_t scanner) +{ + EnableMacros(scanner); + yyextra->commentNesting--; + return yyextra->commentNesting; +} + +/*---------------------------------------------------- + Raw string delimiter count +----------------------------------------------------*/ +void rawStringSetDelimCount(int count, yyscan_t scanner) +{ + EnableMacros(scanner); + yyextra->delimCount = count; +} + +int rawStringGetDelimCount(yyscan_t scanner) +{ + EnableMacros(scanner); + return yyextra->delimCount; +} + +/*---------------------------------------------------- + Numbers +----------------------------------------------------*/ +static void filter_underscore( char* buf, const char* src, size_t bufsize ) { + size_t i = 0; + while( i < bufsize - 1 && *src != 0) { + if (*src != '_') { + buf[i++] = *src; + } + src++; + } + buf[i] = 0; +} + +double numdouble( const char* s ) { + char buf[256]; + filter_underscore(buf,s,256); + return strtod(buf, NULL); +} + +long numlong( const char* s, int base ) { + char buf[256]; + filter_underscore(buf,s,256); + return strtol(buf, NULL, base ); +} + + +/*---------------------------------------------------- + string allocation +----------------------------------------------------*/ +char* stringDup( const char* s, yyscan_t scanner ) +{ + EnableMacros(scanner); + char* t = strdup(s); + if (t==NULL) { + yyerror(yylloc,scanner,"out of memory while scanning an identifier"); + exit(1); + } + alistAdd( &yyextra->allocated, t ); + return t; +} + +/*---------------------------------------------------- + identifier allocation +----------------------------------------------------*/ + +bool isLetter(char c) { + return ((c>='a' && c <= 'z') || (c>='A' && c<='Z') || c=='\0' || c==' '); +} +bool isDigit(char c) { + return (c>='0' && c <= '9'); +} + +bool wellformed( const char* s ) { + char prev = '\0'; + char next = '\0'; + const char* c; + for(c = s; *c != 0; c++) { + next = *(c+1); + if (*c=='-' && !((isLetter(prev) || isDigit(prev)) && isLetter(next))) return false; + if (*c=='(') return true; // qualified operator, or operator name + prev = *c; + } + return true; +} + +char* identifier( const char* s, yyscan_t scanner, bool wellformedCheck ) +{ + EnableMacros(scanner); + if (wellformedCheck && !wellformed(s)) yyerror(yylloc,scanner,"malformed identifier: a dash must be preceded and followed by a letter"); + return stringDup(s,scanner); +} + + +/*---------------------------------------------------- + String literals +----------------------------------------------------*/ +void stringStart( yyscan_t scanner ) +{ + EnableMacros(scanner); + yyextra->stringLen = 0; +} + +void stringAddStr( const char* s, yyscan_t scanner) { + while (*s) { + stringAdd( *s++, scanner); + } +} + +void stringAdd( unsigned int c, yyscan_t scanner) +{ + EnableMacros(scanner); + /* reallocate if necessary (always 5 more to accomodate any UTF-8 encoding + \0 char) */ + int len = yyextra->stringLen; + + if (len >= yyextra->stringMax) { + int newsize = (yyextra->stringMax==0 ? 128 : yyextra->stringMax*2); + char* buf = (char*)malloc(newsize+5); + if (buf==NULL) { + yyerror(yylloc,scanner,"out of memory while scanning a string"); + exit(1); + } + if (yyextra->stringBuf != NULL) { + strcpy(buf,yyextra->stringBuf); + free(yyextra->stringBuf); + } + yyextra->stringBuf = buf; + yyextra->stringMax = newsize; + } + /* add the new character to the buffer */ + /* encode to (modified) UTF-8 */ + if (c == 0) { + yyextra->stringBuf[len++] = 0xC0; + yyextra->stringBuf[len++] = 0x80; + } + else if (c <= 0x7F) { + yyextra->stringBuf[len++] = c; + } + else if (c <= 0x7FF) { + yyextra->stringBuf[len++] = (0xC0 | (c >> 6)); + yyextra->stringBuf[len++] = (0x80 | (c & 0x3F)); + } + else if (c <= 0xFFFF) { + yyextra->stringBuf[len++] = 0xE0 | (c >> 12); + yyextra->stringBuf[len++] = 0x80 | ((c >> 6) & 0x3F); + yyextra->stringBuf[len++] = 0x80 | (c & 0x3F); + } + else if (c <= 0x10FFFF) { + yyextra->stringBuf[len++] = 0xF0 | (c >> 18); + yyextra->stringBuf[len++] = 0x80 | ((c >> 12) & 0x3F); + yyextra->stringBuf[len++] = 0x80 | ((c >> 6) & 0x3F); + yyextra->stringBuf[len++] = 0x80 | (c & 0x3F); + } + else { + yyerror(yylloc,scanner,"illegal unicode character (0x%X)", c ); + } + /* always add a 0 at the end */ + yyextra->stringBuf[len] = 0; + yyextra->stringLen = len; +} + +char* stringEnd( yyscan_t scanner ) +{ + EnableMacros(scanner); + + char* buf = (char*)malloc((yyextra->stringLen+1)); + if (buf==NULL) { + yyerror(yylloc,scanner, "out of memory while scanning a string"); + exit(1); + } + alistAdd( &yyextra->allocated, buf); + if (yyextra->stringLen > 0) { + strcpy(buf,yyextra->stringBuf); + } + else { + buf[0] = 0; + } + return buf; +} + +/* Decode a UTF8 encoded character. + "len" should be 1 or larger, and gets set to the actual number of bytes read (<= len) + For an invalid UTF8 sequence, return the replacement character and set len to 0. */ +unsigned int utfDecode1( const char* buf, int* len ) +{ + unsigned int c = (unsigned char)(buf[0]); + if (c <= 0x7F && *len>=1) { + *len = 1; + return c; + } + else if (c >= 0xC2 && c <= 0xDF && *len>=2) { + unsigned int c1 = (unsigned char)(buf[1]); + *len = 2; + return (((c&0x1F)<<6) | (c1&0x3F)); + } + else if (c >= 0xE0 && c <= 0xEF && *len>=3) { + unsigned int c1 = (unsigned char)(buf[1]); + unsigned int c2 = (unsigned char)(buf[2]); + *len = 3; + return (((c&0x0F)<<12) | ((c1&0x3F)<<6) | (c2&0x3F)); + } + else if (c >= 0xF0 && c <= 0xF4 && *len>=4) { + unsigned int c1 = (unsigned char)(buf[1]); + unsigned int c2 = (unsigned char)(buf[2]); + unsigned int c3 = (unsigned char)(buf[3]); + *len = 4; + return (((c&0x07)<<18) | ((c1&0x3F)<<12) | ((c2&0x3F)<<6) | (c3&0x3F)); + } + else { + *len = 0; + return 0xFFFD; /* replacement character */ + } +} + +/* Unsafe bidi characters */ +static bool utfIsUnsafe( unsigned int c ) { + return ((c >= 0x200E && c <= 0x200F) || + (c >= 0x202A && c <= 0x202E) || + (c >= 0x2066 && c <= 0x2069)); +} + +/* Decode a UTF8 encoded character */ +unsigned int utfDecode( const char* buf, int len, yyscan_t scanner ) +{ + int scanned = len; + unsigned int c = utfDecode1( buf, &scanned ); + if (scanned != len || len == 0) { + YYLTYPE loc = currentLoc(scanner); + yyerror( &loc, scanner, "illegal UTF-8 character sequence encountered: %s", buf ); + } + if (utfIsUnsafe(c)) { + YYLTYPE loc = currentLoc(scanner); + yyerror( &loc, scanner, "unsafe bidi character encountered: u%4X", c ); + } + return c; +} + + +/*---------------------------------------------------- + Errors +----------------------------------------------------*/ +void illegal(char* s, yyscan_t scanner ) +{ + YYLTYPE loc = currentLoc(scanner); + yyerror(&loc,scanner, s ); +} + +void illegalchar( char c, char* s, yyscan_t scanner ) +{ + YYLTYPE loc = currentLoc(scanner); + const char* schar = showChar(c,scanner); + if (s == NULL && c == '\t') { + s = "(replace tabs with spaces)"; + } + if (s == NULL || strlen(s) == 0) { + yyerror(&loc,scanner, "illegal character '%s'", schar); + } + else { + yyerror(&loc,scanner, "illegal character '%s' %s", schar, s ); + } +} + +void yyerror( YYLTYPE* loc, yyscan_t scanner, char* s, ... ) +{ + EnableMacros(scanner); + va_list ap; + va_start(ap, s); + + // print location + if (loc->first_line >= 1) { + fprintf(stderr,"(%d,%2d)-(%d,%2d): ", loc->first_line, loc->first_column, + loc->last_line, loc->last_column); + } + + // print message + vfprintf(stderr, s, ap); + fprintf(stderr, "\n"); + + // check error count + yyextra->errorCount++; + if (yyextra->errorCount >= errorMax) { + fprintf(stderr, "maximum number of errors reached.\n" ); + exit(1); + } +} + +/*---------------------------------------------------- + Main +----------------------------------------------------*/ +int yyparse( yyscan_t scanner ); + +static bool isPrefix( const char* pre, const char* s ) { + if (pre==NULL) return true; + if (s==NULL) return (pre[0] == 0); + while (pre[0] != 0) { + if (pre[0] != s[0]) return false; + pre++; + s++; + } + return true; +} + +int main( int argc, char** argv ) +{ + /* initialize */ + yyscan_t scanner; + yylex_init( &scanner ); + EnableMacros(scanner); + + ExtraState st; + initScanState( &st ); + yyset_extra( &st, scanner ); + + /* read argument and parse */ + int arg = 1; + while (arg < argc) { + if (strcmp( argv[arg], "--nosemi") == 0) { + st.noLayout = true; + } + else if (strcmp( argv[arg], "--verbose") == 0 || strcmp(argv[arg], "-v") == 0) { + st.verbose++; + } + else if (isPrefix( "--tab=", argv[arg])) { + st.tab = atoi(argv[arg]+6); + } + else if (strcmp( argv[arg], "--help") == 0) { + yyin=NULL; + break; + } + else if (argv[arg][0] == '-') { + fprintf(stderr,"unrecognized option: %s\n", argv[arg] ); + exit(1); + } + else if (yyin != NULL) { + fprintf(stderr,"too many file parameters: %s\n", argv[arg]); + exit(1); + } + else { + yyin = fopen(argv[arg], "r"); + if (!yyin) { + fprintf(stderr,"couldn't open file: %s\n", argv[arg]); + exit(1); + } + else { + // skip UTF-8 BOM ? + bool skippedBOM = (fgetc(yyin)==0xEF && fgetc(yyin)==0xBB && fgetc(yyin)==0xBF); + if (!skippedBOM) { + fseek(yyin,0,SEEK_SET); // rewind + } + else if (st.verbose) { + fprintf(stderr,"skipped BOM\n"); + } + } + } + arg++; + } + + if (yyin==NULL) { + printf("usage: koka-parser [--nosemi|--verbose|-v] \n"); + } + else { + yyparse(scanner); + + /* destroy */ + int errorCount = st.errorCount; + int lineCount = st.line; + yylex_destroy(scanner); + doneScanState(&st); + + /* final message */ + if (errorCount == 0) { + printf("Success! (%i lines parsed)\n", lineCount); + return 0; + } + else { + printf("Failure (%i errors encountered)\n", errorCount); + return 1; + } + } +} + + + + +/*---------------------------------------------------- + Nicely print a token to stderr +----------------------------------------------------*/ +char* showChar( unsigned int c, yyscan_t scanner ) +{ + char buf[11]; /* 11 = format of \U%06X + zero byte */ + if (c >= ' ' && c <= '~' && c != '\\' && c != '\'' && c != '\"') { + sprintf(buf,"%c",c); + } + else if (c <= 0xFF) { + if (c=='\t') sprintf(buf,"\\t"); + else if (c=='\n') sprintf(buf,"\\n"); + else if (c=='\r') sprintf(buf,"\\r"); + else if (c=='\'') sprintf(buf,"\\'"); + else if (c=='\"') sprintf(buf,"\\\""); + else sprintf(buf,"\\x%02X",c); + } + else if (c <= 0xFFFF) { + sprintf(buf,"\\u%04X",c); + } + else if (c <= 0xFFFFFF) { + sprintf(buf,"\\U%06X",c); + } + else { + sprintf(buf,"\\X%08X",c); + } + return stringDup(buf,scanner); +} + +char* showString( const char* s, yyscan_t scanner ) +{ + if (s==NULL) return ""; + + const int max = 60; + char buf[max + 10 + 3 + 1]; // max + maximal character width + " .." 0 + int dest = 0; + int src = 0; + int slen = strlen(s); + buf[dest++] = '"'; + while (dest < max && s[src] != 0) { + int len = slen - src; + unsigned int c = utfDecode1(s + src,&len); + if (len==0) src++; + else src += len; + const char* schar = showChar(c,scanner); + strcpy(buf+dest,schar); + dest += strlen(schar); + } + if (s[src] == 0) { + buf[dest++] = '"'; + } + else { + buf[dest++] = ' '; + buf[dest++] = '.'; + buf[dest++] = '.'; + } + buf[dest] = 0; + return stringDup(buf,scanner); +} + +void printToken( int token, int state, yyscan_t scanner ) +{ + EnableMacros(scanner); + + fprintf(stderr,"(%2d,%2d)-(%2d,%2d) 0x%04x <%d> [", yylloc->first_line, yylloc->first_column, yylloc->last_line, yylloc->last_column, token, state ); + for(int i = 0; i <= yyextra->layoutTop; i++) { + fprintf(stderr, "%d%s", yyextra->layout[i], (i==yyextra->layoutTop ? "" : ",") ); + } + fprintf(stderr, "]: "); + switch(token) { + case ID: fprintf(stderr,"ID = '%s'", yylval->Id); break; + case CONID: fprintf(stderr,"CONID = '%s'", yylval->Id); break; + case OP: fprintf(stderr,"OP = '%s'", yylval->Id); break; + case QID: fprintf(stderr,"QID = '%s'", yylval->Id); break; + case QCONID: fprintf(stderr,"QCONID= '%s'", yylval->Id); break; + // case QOP: fprintf(stderr,"QOP = '%s'", yylval->Id); break; + case INT: fprintf(stderr,"INT = '%lu'", yylval->Int); break; + case FLOAT: fprintf(stderr,"FLOAT = '%g'", yylval->Float); break; + case CHAR: fprintf(stderr,"CHAR = '%s'", showChar(yylval->Char,scanner)); break; + case INSERTED_SEMI: fprintf(stderr,"; = (inserted)"); break; + case STRING: fprintf(stderr,"STRING(%zu) = %s", strlen(yylval->String), showString(yylval->String,scanner)); break; + default: { + if (token >= ' ' && token <= '~') + fprintf(stderr,"%c", token); + else if (token < ' ') + fprintf(stderr,"0x%x", token ); + else + fprintf(stderr,"%s", yytext); + } + } + fprintf(stderr,"\n"); +} + + + +/*--------------------------------------------------------- + The allocation list + Used to free memory allocted of identifiers and + string literals. +---------------------------------------------------------*/ +struct _allocList { + struct _allocList* next; + void* mem; +}; + +void alistAdd( allocList* list, void* p ) +{ + if (p == NULL) return; + + allocList head = (allocList)malloc(sizeof(struct _allocList)); + if (head == NULL) return; + + head->mem = p; + head->next = *list; + *list = head; +} + +void alistFree( allocList* list ) +{ + allocList head = *list; + + while (head != NULL) { + allocList next = head->next; + if (head->mem != NULL) { + free(head->mem); + } + free(head); + head = next; + } +} diff --git a/doc/spec/install.mdk b/doc/spec/install.mdk index 01d6421e8..a4f2f5b62 100644 --- a/doc/spec/install.mdk +++ b/doc/spec/install.mdk @@ -15,6 +15,15 @@ [logo-debian]: images/logo-debian.svg { height: 1em; vertical-align: -0.4ex; } [logo-freebsd]: images/logo-freebsd.svg { height: 0.8em; vertical-align: -0.2ex; } +[Homebrew]: https://brew.sh + +On macOS (x64, M1), you can install and upgrade &koka; using Homebrew: + +&acopy; +{.copy; data-value:"brew install koka"} + + \(**brew install koka**\) + On Windows (x64), open a ``cmd`` prompt and use: &acopy; @@ -22,7 +31,7 @@ On Windows (x64), open a ``cmd`` prompt and use: \(**curl -sSL -o %tmp%\install-koka.bat https://github.com/koka-lang/koka/releases/latest/download/install.bat && %tmp%\install-koka.bat**\) -On Linux (x64, arm64), macOS (x64, M1), and FreeBSD (x64), you can install &koka; using: +On Linux (x64, arm64) and FreeBSD (x64) (and macOS), you can install &koka; using: &acopy; {.copy; data-value:"curl -sSL https://github.com/koka-lang/koka/releases/latest/download/install.sh | sh"} diff --git a/doc/spec/koka.bib b/doc/spec/koka.bib index fd4bf412a..f36d01855 100644 --- a/doc/spec/koka.bib +++ b/doc/spec/koka.bib @@ -1,3 +1,13 @@ +@article{Boucher:trojan, + title = {Trojan {Source}: {Invisible} {Vulnerabilities}}, + author = {Nicholas Boucher and Ross Anderson}, + year = {2021}, + journal = {Preprint}, + eprint = {2111.00169}, + archivePrefix = {arXiv}, + primaryClass = {cs.CR}, + url = {https://arxiv.org/abs/2111.00169} +} @techreport{Lorenzen:reuse-tr, author = {Lorenzen, Anton and Leijen, Daan}, diff --git a/doc/spec/spec.kk.md b/doc/spec/spec.kk.md index 9624304c3..0e314d815 100644 --- a/doc/spec/spec.kk.md +++ b/doc/spec/spec.kk.md @@ -1,788 +1,800 @@ - -# &koka; language specification - -This is the draft language specification of the &koka; language, version v&kokaversion;\ -Currently only the lexical and context-free grammar are specified. -The [standard libraries][stdlib] are documented separately. - -[stdlib]: toc.html - -## Lexical syntax - -We define the grammar and lexical syntax of the language using standard BNF -notation where non-terminals are generated by alternative patterns: - -|~~~~~~~~~~~|~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| -| _nonterm_ | ::= | _pattern_~1~ []{.bar} _pattern_~2~ | | -{.grammar} - -In the patterns, we use the following notations: - -|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| `terminal` | | A terminal symbol (in ascii) | -| ``x0B`` | | A character with hexadecimal code 0B | -| ``a..f`` | | The characters from "a" to "f" (using ascii, i.e. ``0x61..0x66``) | -|   | | | -| ( _pattern_ ) | | Grouping | -| [ _pattern_ ] | | Optional occurrence of _pattern_ | -| { _pattern_ } | | Zero or more occurrences of _pattern_ | -| _pattern_~1~ []{.bar} _pattern_~2~ | | Choice: either _pattern_~1~ or _pattern_~2~ | -|   | | | -| _pattern_~<!_diff_>~ | | Difference: elements generated by _pattern_ except those in _diff_ | -| _nonterm_~[\/_lex_]~ | | Generate _nonterm_ by drawing lexemes from _lex_ | -{.grammar} - - - -Care must be taken to distinguish meta-syntax such as - []{.bar} and ) -from concrete terminal symbols as ``|`` and ``)``. In the specification -the order of the productions is not important and at each point the -_longest matching lexeme_ is preferred. For example, even though -`fun` is a reserved word, the word `functional` is considered a -single identifier. A _prefix_ or _postfix_ pattern is included -when considering a longest match. -{.grammar} - -### Source code - -Source code consists of a sequence of 8-bit characters. Valid characters in -actual program code consists strictly of ASCII characters which range from 0 -to 127 and can be encoded in 7-bits. Only comments, string literals, and -character literals are allowed to contain extended 8-bit characters. - -### Encoding - -A program source is assumed to be UTF-8 encoded which allows comments, -string literals, and character literals to contain (encoded) unicode -characters. Moreover, the grammar is designed such that a lexical -analyzer and parser can directly work on source files without doing UTF-8 -decoding or unicode category identification. To further facilitate the -processing of UTF-8 encoded files the lexical analyzer ignores an initial -byte-order mark that some UTF-8 encoders insert. In particular, any -program source is allowed to start with three byte-order mark bytes -``0xEF``, ``0xBB``, and ``0xBF``, which are ignored. - -## Lexical grammar - -In the specification of the lexical grammar all white space is explicit -and there is no implicit white space between juxtaposed symbols. The -lexical token stream is generated by the non-terminal _lex_ which -consists of lexemes and whitespace. - -Before doing lexical analysis, there is a _linefeed_ character inserted -at the start and end of the input, which makes it easier to specify line -comments and directives. - -### Lexical tokens { test } - -| ~~~~~~~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~| -| _lex_ | ::= | _lexeme_ []{.bar} _whitespace_ | | -| _lexeme_   | ::= | _conid_ []{.bar} _qconid_ | | -| | &bar; | _varid_ []{.bar} _qvarid_ | | -| | &bar; | _op_ []{.bar} _opid_ []{.bar} _qopid_ []{.bar} _wildcard_ | | -| | &bar; | _integer_ []{.bar} _float_ []{.bar} _string_ []{.bar} _char_ | | -| | &bar; | _reserved_ []{.bar} _opreserved_ | | -| | &bar; | _special_ | | -{.grammar .lex} - -The main program consists of _whitespace_ or _lexeme_'s. The context-free -grammar will draw it's lexemes from the _lex_ production. - -### Identifiers - -|~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~| -| _anyid_ | ::= | _varid_ []{.bar} _qvarid_ []{.bar} _opid_ []{.bar} _qopid_ []{.bar} _conid_ []{.bar} _qconid_ | | -|   | | | | -| _qconid_ | ::= | _modulepath_ _conid_ | | -| _qvarid_ | ::= | _modulepath_ _lowerid_ | | -| _modulepath_ | ::= | _lowerid_ `/` [_lowerid_ `/`]{.many} | | -|   | | | | -| _conid_ | ::= | _upperid_ | | -| _varid_ | ::= | _lowerid_~<!_reserved_>~ | | -|   | | | | -| _lowerid_ | ::= | _lower_ _idtail_ | | -| _upperid_ | ::= | _upper_ _idtail_ | | -| _wildcard_ | ::= | ``_`` _idtail_ | | -| _typevarid_ | ::= | _letter_ [_digit_]{.many} | | -|   | | | | -| _idtail_ | ::= | [_idchar_]{.many} [_idfinal_]{.opt} | | -| _idchar_ | ::= | _letter_ []{.bar} _digit_ []{.bar} ``_`` []{.bar} ``-`` | | -| _idfinal_ | ::= | [``'``]{.many} | | -|   | | | | -| _reserved_ | ::= | `infix` []{.bar} `infixr` []{.bar} `infixl` | | -| | &bar; | ``module`` []{.bar} `import` []{.bar} `as` | | -| | &bar; | ``pub`` []{.bar} `abstract` | | -| | &bar; | `type` []{.bar} `struct` []{.bar} `alias` []{.bar} `effect` []{.bar} `con` | | -| | &bar; | `forall` []{.bar} `exists` []{.bar} `some` | | -| | &bar; | `fun` []{.bar} `fn` []{.bar} `val` []{.bar} `var` []{.bar} `extern` | | -| | &bar; | `if` []{.bar} `then` []{.bar} `else` []{.bar} `elif` | | -| | &bar; | `match` []{.bar} `return` []{.bar} `with` []{.bar} `in` | | -| | &bar; | `handle` []{.bar} `handler` []{.bar} `mask` | | -| | &bar; | `ctl` []{.bar} `final` []{.bar} `raw` | | -| | &bar; | `override` []{.bar} `named` | | -| | &bar; | `interface` []{.bar} `break` []{.bar} `continue` []{.bar} `unsafe` | (future reserved words) | -|   | | | | -| _specialid_ | ::= | `co` []{.bar} `rec` []{.bar} `open` []{.bar} `extend` []{.bar} `behind` | | -| | &bar; | `linear` []{.bar} `value` []{.bar} `reference` | | -| | &bar; | `inline` []{.bar} `noinline` []{.bar} `initially` []{.bar} `finally` | | -| | &bar; | `js` []{.bar} `c` []{.bar} `cs` []{.bar} `file` | | -{.grammar .lex} - -Identifiers always start with a letter, may contain underscores and -dashes, and can end with prime ticks. -Like in Haskell, constructors always begin with an uppercase -letter while regular identifiers are lowercase. The rationale is to -visibly distinguish constants from variables in pattern matches. -Here are some example of valid identifiers: -```unchecked -x -concat1 -visit-left -is-nil -x' -Cons -True -``` -To avoid confusion with the subtraction operator, the occurrences of -dashes are restricted in identifiers. After lexical analysis, only -identifiers where each dash is surrounded on both sides with a _letter_ -are accepted: - -````koka -fold-right -n-1 // illegal, a digit cannot follow a dash -n - 1 // n minus 1 -n-x-1 // illegal, a digit cannot follow a dash -n-x - 1 // identifier "n-x" minus 1 -n - x - 1 // n minus x minus 1 -```` -Qualified identifiers are prefixed with a module path. Module -paths can be partial as long as they are unambiguous. - -````koka -core/map -std/core/(&) -```` - -### Operators and symbols - -| ~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| -| _qopid_ | ::= | _modulepath_ _opid_ | | -| _opid_ | ::= | `(` _symbols_ `)` | | -|   | | | | -| _op_ | ::= | _symbols_~<!\ _opreserved_[]{.bar}_optype_>~ []{.bar} ``\(&bar;&bar;\)`` | | -|   | | | | -| _symbols_ | ::= | _symbol_ [_symbol_]{.many}[]{.bar} ``/`` | | -| _symbol_ | ::= | `$` []{.bar} `%` []{.bar} ``&`` []{.bar} `*` []{.bar} `+` | | -| | &bar; | ``~`` []{.bar} ``!`` []{.bar} ``\`` []{.bar} `^` []{.bar} ``#`` | | -| | &bar; | ``=`` []{.bar} ``.`` []{.bar} ``:`` []{.bar} `-` []{.bar} `?` | | -| | &bar; | _anglebar_ | | -| _anglebar_ | ::= | ``<`` []{.bar} ``>`` []{.bar} ``\(&bar;\)`` | | -|   | | | | -| _opreserved_ | ::= | `=` []{.bar} `.` []{.bar} ``:`` []{.bar} `->` | | -| _optype_ | ::= | _anglebar_ _anglebar_ [_anglebar_]{.many} | | -|   | | | | -| _special_ | ::= | `{` []{.bar} `}` []{.bar} `(` []{.bar} `)` []{.bar} `[` []{.bar} `]` []{.bar} ``\(&bar;\)`` []{.bar} `;` []{.bar} `,` | | -|   | | | | -{.grammar .lex} - -### Literals - -|~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~| -| _char_ | ::= | ``'`` ( _graphic_~<``'``[]{.bar}``\``>~ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _escape_ ) ``'`` | | -| _string_ | ::= | ``"`` [_graphic_~<``"``[]{.bar}``\``>~ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _escape_]{.many} ``"`` | | -| | &bar; | ``r`` _rawstring_ | | -| _rawstring_ | ::= | ``#`` _rawstring_ ``#`` | | -| | &bar; | ``"`` [_graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ []{.bar} _newline_]{.many} ``"`` | (non-greedy match) | -|   | | | | -| _escape_ | ::= | ``\`` ( _charesc_ []{.bar} _hexesc_ ) | | -| _charesc_ | ::= | `n` []{.bar} `r` []{.bar} `t` []{.bar} ``\`` []{.bar} ``"`` []{.bar} ``'`` | | -| _hexesc_ | ::= | `x` _hexdigit_~2~ []{.bar} `u` _hexdigit_~4~ []{.bar} ``U`` _hexdigit_~4~ _hexdigit_~2~ | | -| _hexdigit_~4~ | ::= | _hexdigit_ _hexdigit_ _hexdigit_ _hexdigit_ | | -| _hexdigit_~2~ | ::= | _hexdigit_ _hexdigit_ | | -|   | | | | -| _float_ | ::= | [``-``]{.opt} (decfloat []{.bar} hexfloat) | | -| _decfloat_ | ::= | _decimal_ (`.` _digits_ [_decexp_]{.opt} []{.bar} _decexp_) | | -| _decexp_ | ::= | (``e`` &bar; ``E``) _exponent_ | | -| _hexfloat_ | ::= | _hexadecimal_ (`.` _hexdigits_ [_hexexp_]{.opt} []{.bar} _hexexp_) | | -| _hexexp_ | ::= | (``p`` &bar; ``P``) _exponent_ | | -| _exponent_ | ::= | [``-`` &bar; ``+``]{.opt} _digit_ [_digit_]{.many} | | -|   | | | | -| _integer_ | ::= | [``-``]{.opt} (_decimal_ []{.bar} _hexadecimal_) | | -| _decimal_ | ::= | ``0`` &bar; _posdigit_ [[``_``]{.opt} _digits_]{.opt} | | -| _hexadecimal_ | ::= | ``0`` (``x`` &bar; ``X``) _hexdigits_ | | -| _digits_ | ::= | _digit_ [_digit_]{.many} [``_`` _digit_ [_digit_]{.many}]{.many} | | -| _hexdigits_ | ::= | _hexdigit_ [_hexdigit_]{.many} [``_`` _hexdigit_ [_hexdigit_]{.many}]{.many} | | -{.grammar .lex} - -### White space - -|~~~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _whitespace_ | ::= | _white_ [_white_]{.many} []{.bar} _newline_ | | -| _white_ | ::= | _space_ | | -| | &bar; | _linecomment_ []{.bar} _blockcomment_ | | -| | &bar; | _linedirective_ | | -|   | | | | -| _linecomment_ | ::= | ``//`` [_linechar_]{.many} | | -| _linedirective_ | ::= | _newline_ ``#`` [_linechar_]{.many} | | -| _linechar_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ | | -|   | | | | -| _blockcomment_ | ::= | /* _blockpart_ [_blockcomment_ _blockpart_]{.many} */ | (allows nested comments) | -| _blockpart_ | ::= | _blockchars_~<_blockchars_\ (/*[]{.bar}*/)\ _blockchars_>~ | | -| _blockchars_ | ::= | [_blockchar_]{.many} | | -| _blockchar_ | ::= | _graphic_ []{.bar} _utf8_ []{.bar} _space_ []{.bar} _tab_ []{.bar} _newline_ | | -{.grammar .lex} - -### Character classes - -|~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _letter_ | ::= | _upper_ []{.bar} _lower_ | | -| _upper_ | ::= | ``A..Z`` | (i.e. ``x41..x5A``) | -| _lower_ | ::= | ``a..z`` | (i.e. ``x61..x7A``) | -| _digit_ | ::= | ``0..9`` | (i.e. ``x30..x39``) | -| _posdigit_ | ::= | ``1..9`` | | -| _hexdigit_ | ::= | ``a..f`` []{.bar} ``A..F`` []{.bar} _digit_ | | -|   | | | | -| _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | -|   | | | | -| _space_ | ::= | ``x20`` | (a space) | -| _tab_ | ::= | ``x09`` | (a tab (``\t``)) | -| _linefeed_ | ::= | ``x0A`` | (a line feed (``\n``)) | -| _return_ | ::= | ``x0D`` | (a carriage return (``\r``)) | -| _graphic_ | ::= | ``x21``..``x7E`` | (a visible character) | -|   | | | | -| _utf8_ | ::= | (``xC2``..``xDF``) _cont_ | | -| | &bar; | ``xE0`` (``xA0``..``xBF``) _cont_ | | -| | &bar; | (``xE1``..``xEC``) _cont_ _cont_ | | -| | &bar; | ``xED`` (``x80``..``x9F``) _cont_ | | -| | &bar; | (``xEE``..``xEF``) _cont_ _cont_ | | -| | &bar; | ``xF0`` (``x90``..``xBF``) _cont_ _cont_ | | -| | &bar; | (``xF1``..``xF3``) _cont_ _cont_ _cont_ | | -| | &bar; | ``xF4`` (``x80``..``x8F``) _cont_ _cont_ | | -| _cont_ | ::= | ``x80``..``xBF`` | | -{.grammar .lex} - - -## Layout {#sec-layout} - -[Haskell]: http://www.haskell.org/onlinereport/haskell2010/haskellch10.html#x17-17800010.3 -[Python]: http://docs.python.org/2/reference/lexical_analysis.html -[JavaScript]: https://tc39.github.io/ecma262/#sec-rules-of-automatic-semicolon-insertion -[Scala]: http://www.scala-lang.org/old/sites/default/files/linuxsoft_archives/docu/files/ScalaReference.pdf#page=13 -[Go]: http://golang.org/ref/spec#Semicolons - - -Just like programming languages like -[Haskell], [Python], [JavaScript], [Scala], [Go], etc., there is a layout rule -which automatically adds braces and semicolons at appropriate places: - -* Any block that is _indented_ is automatically wrapped with curly braces: - ``` - fun show-messages1( msgs : list ) : console () - msgs.foreach fn(msg) - println(msg) - ``` - is elaborated to: - ```unchecked - fun show-messages1( msgs : list ) : console () { - msgs.foreach fn(msg) { - println(msg) - } - } - ``` - -* Any statements and declarations that are _aligned_ in a block are terminated with semicolons, that is: - ``` - fun show-messages2( msgs : list ) : console () - msgs.foreach fn(msg) - println(msg) - println("--") - println("done") - ``` - is fully elaborated to: - ```unchecked - fun show-messages2( msgs : list ) : console () { - msgs.foreach fn(msg){ - println(msg); - println("--"); - }; - println("done"); - } - ``` - -* Long expressions or declarations can still be indented without getting braces or semicolons - if it is clear from the start- or previous token that the line continues - an expression or declaration. Here is a contrived example: - ``` - fun eq2( x : int, - y : int ) : io bool - print("calc " ++ - "equ" ++ - "ality") - val result = if (x == y) - then True - else False - result - ``` - is elaborated to: - ```unchecked - fun eq2( x : int, - y : int ) : io bool { - print("calc " ++ - "equ" ++ - "ality"); - val result = if (x == y) - then True - else False; - result - } - ``` - Here the long string expression is indented but no braces or semicolons - are inserted as the previous lines end with an operator (`++`). - Similarly, in the `if` expression no braces or semicolons are inserted - as the indented lines start with `then` and `else` respectively. - In the parameter declaration, the `,` signifies the continuation. - More precisely, for long expressions and declarations, indented or aligned lines - do not get braced or semicolons if: - - 1. The line starts with a clear expression or declaration _start continuation token_, - namely: an operator (including `.`), `then`, `else`, `elif`, - a closing brace (`)`, `>`, `]`, or `}`), - or one of `,`, `->`, `{` , `=`, `|`, `::`, `.`, `:=`. - 2. The previous line ends with a clear expression or declaration _end continuation token_, - namely an operator (including `.`), an open brace (`(`, `<`, `[`, or `{`), or `,`. - -The layout algorithm is performed on the token stream in-between lexing -and parsing, and is independent of both. In particular, there are no intricate -dependencies with the parser (which leads to very complex layout rules, as is the -case in languages like [Haskell] or [JavaScript]). - -Moreover, in contrast to purely token-based layout rules (as in [Scala] or [Go] for example), -the visual indentation in a Koka program corresponds directly to how the compiler -interprets the statements. Many tricky layout -examples in other programming languages are often based on a mismatch between -the visual representation and how a compiler interprets the tokens -- with -&koka;'s layout rule such issues are largely avoided. - -Of course, it is still allowed to explicitly use semicolons and braces, -which can be used for example to put multiple statements on a single line: - -``` -fun equal-line( x : int, y : int ) : io bool { - print("calculate equality"); (x == y) -} -``` - -The layout algorithm also checks for invalid layouts where the layout would -not visually correspond to how the compiler interprets the tokens. In -particular, it is illegal to indent less than the layout context or to put -comments into the indentation (because of tabs or potential unicode -characters). For example, the program: - -```unchecked -fun equal( x : int, y : int ) : io bool { - print("calculate equality") - result = if (x == y) then True // wrong: too little indentation - /* wrong */ else False - result -} -``` - -is rejected. In order to facilitate code generation or source code -compression, compilers are also required to support a mode where the layout -rule is not applied and no braces or semicolons are inserted. A recognized command -line flag for that mode should be ``--nolayout``. - -### The layout algorithm - -To define the layout algorithm formally, we first establish some terminology: - -* A new line is started after every _linefeed_ character. -* Any non-_white_ token is called a _lexeme_, where a line without lexemes - is called _blank_. -* The indentation of a lexeme is the column number of its first character on - that line (starting at 1), and the indentation of a line is the indentation - of the first lexeme on the line. -* A lexeme is an _expression continuation_ if it is the first lexeme on a line, - and the lexeme is a _start continuation token_, or the previous lexeme is an - _end continuation token_ (as defined in the previous section). - -Because braces can be nested, we use a _layout stack_ of strictly -increasing indentations. The top indentation on the layout stack holds the -_layout indentation_. The initial layout stack contains the single -value 0 (which is never popped). We now proceed through the token stream -where we perform the following operations in order: first brace insertion, -then layout stack operations, and finally semicolon insertion: - -* _Brace insertion_: For each non-blank line, consider the first lexeme on the line. - If the indentation is larger than the layout indentation, and the lexeme - is not an _expression continuation_, then insert an open brace `{` before the lexeme. - If the indention is less than the layout indentation, and the lexeme is not already a - closing brace, insert a closing brace `}` before the lexeme. - -* _Layout stack operations_: If the previous lexeme was an - open brace `{` or the start of the lexical token sequence, we push the - indentation of the current lexeme on the layout stack. The pushed indentation - must be larger than the previous layout indentation (unless the current lexeme - is a closing brace). When a closing brace `}` is encountered the top - indentation is popped from the layout stack. - -* _Semicolon insertion_: For each non-blank line, the - indentation must be equal or larger to the layout indentation. - If the indentation is equal to the layout indentation, and the first - lexeme on the line is not an _expression continuation_, a semicolon - is inserted before the lexeme. - Also, a semicolon is always inserted before a closing brace `}` and - before the end of the token sequence. -{.grammar} - -As defined, braces are inserted around any indented blocks, semicolons -are inserted whenever statements or declarations are -aligned (unless the lexeme happens to be a clear expression continuation). To -simplify the grammar specification, a semicolon is also always inserted before -a closing brace and the end of the source. This allows us to specify many -grammar elements as ended by semicolons instead of separated by semicolons -which is more difficult to specify for a LALR(1) grammar. - -The layout can be implemented as a separate transformation on the lexical token -stream (see the [Haskell][HaskellLayout] implementation in the Koka compiler), -or directly as part of the lexer (see the [Flex][FlexLexer] implementation) - -### Implementation { #sec:lex-implementation } - -There is a full [Flex (Lex) implementation][FlexLexer] of lexical -analysis and the layout algorithm. -Ultimately, the Flex implementation serves as _the_ -specification, and this document and the Flex implementation should -always be in agreement. - -## Context-free syntax - -The grammar specification starts with the non terminal _module_ which draws -its lexical tokens from _lex_ where all _whitespace_ tokens are implicitly -ignored. - -### Modules - -|~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| -| _module_~[_lex_]{.opt}~ | ::= | [_moduledecl_]{.opt} _modulebody_ | | -|   | | | | -| _moduledecl_ | ::= | _semis_ `module` _moduleid_ | | -| _moduleid_ | ::= | _qvarid_ []{.bar} _varid_ | | -|   | | | | -| _modulebody_ | ::= | `{` _semis_ _declarations_ `}` _semis_ | | -| | &bar; | _semis_ _declarations_ | | -|   | | | | -| _semis_ | ::= | [`;`]{.many} | | -| _semi_ | ::= | `;` _semis_ | | -{.grammar .parse} - -### Top level declarations - -|~~~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| -| _declarations_ | ::= | [_importdecl_]{.many} [_fixitydecl_]{.many} _topdecls_ | | -|   | | | | -| _importdecl_ | ::= | [ _pub_]{.opt} `import` [_moduleid_ `=`]{.opt} _moduleid_ _semi_ | | -|   | | | | -| _fixitydecl_ | ::= | [ _pub_]{.opt} _fixity_ _integer_ _identifier_ [`,` _identifier_]{.many} _semi_ | | -| _fixity_ | ::= | `infixl` &bar; `infixr` &bar; `infix` | | -|   | | | | -| _topdecls_ | ::= | [_topdecl_ _semi_]{.many} | | -| _topdecl_ | ::= | [ _pub_]{.opt} _puredecl_ | | -| | &bar; | [ _pub_]{.opt} _aliasdecl_ | | -| | &bar; | [ _pub_]{.opt} _externdecl_ | | -| | &bar; | [ _pubabstract_]{.opt} _typedecl_ | | -| | &bar; | [ _pubabstract_]{.opt} _effectdecl_ | | -|   | | | | -| _pub_ | ::= | `pub` | | -| _pubabstract_ | ::= | `pub` &bar; `abstract` | | -{.grammar .parse} - -### Type Declarations - -| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| -| _aliasdecl_ | ::= | `alias` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} `=` _type_ | | -|   | | | | -| _typedecl_ | ::= | _typemod_ `type` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_typebody_]{.opt} | | -| | &bar; | _structmod_ `struct` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_conparams_]{.opt} | | -|   | | | | -| _typemod_ | ::= | `co` []{.bar} `rec` []{.bar} `open` []{.bar} `extend` []{.bar} _structmod_ | | -| _structmod_ | ::= | `value` []{.bar} `reference` | | -|   | | | | -| _typeid_ | ::= | _varid_ &bar; ``[]`` &bar; `(` [`,`]{.many} `)` &bar; `<` `>` &bar; `<` [&bar;]{.koka; .code} `>` | | -|   | | | | -| _typeparams_ | ::= | `<` [_tbinders_]{.opt} `>` | | -| _tbinders_ | ::= | _tbinder_ [`,` _tbinder_]{.many} | | -| _tbinder_ | ::= | _varid_ [_kannot_]{.opt} | | -| _typebody_ | ::= | `{` _semis_ [_constructor_ _semi_]{.many} `}` | | -|   | | | | -| _constructor_ | ::= | [ _pub_]{.opt} [`con`]{.opt} _conid_ [_typeparams_]{.opt} [_conparams_]{.opt} | | -| _conparams_ | ::= | `{` _semis_ [_parameter_ _semi_]{.many} `}` | | -{.grammar .parse} - -### Value and Function Declarations - -| ~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~| -| _puredecl_ | ::= | [_inlinemod_]{.opt} `val` _valdecl_ | | -| | &bar; | [_inlinemod_]{.opt} `fun` _fundecl_ | | -| _inlinemod_ | ::= | `inline` []{.bar} `noinline` | | -|   | | | | -| _valdecl_ | ::= | _binder_ `=` _blockexpr_ | | -| _binder_ | ::= | _identifier_ [``:`` _type_]{.opt} | | -|   | | | | -| _fundecl_ | ::= | _funid_ _funbody_ | | -| _funbody_ | ::= | _funparam_ _blockexpr_ | | -| _funparam_ | ::= | [_typeparams_]{.opt} _pparameters_ [``:`` _tresult_]{.opt} [_qualifier_]{.opt} | | -| _funid_ | ::= | _identifier_ | | -| | &bar; | ``[`` [`,`]{.many} ``]`` | (indexing operator) | -|   | | | | -| _parameters_ | ::= | `(` [_parameter_ [`,` _parameter_]{.many}]{.opt} `)` | | -| _parameter_ | ::= | [_borrow_]{.opt} _paramid_ [``:`` _type_]{.opt} [`=` _expr_]{.opt} | | -|   | | | | -| _pparameters_ | ::= | `(` [_pparameter_ [`,` _pparameter_]{.many}]{.opt} `)` | (pattern matching parameters) | -| _pparameter_ | ::= | [_borrow_]{.opt} _pattern_ [``:`` _type_]{.opt} [`=` _expr_]{.opt} | | -|   | | | | -| _paramid_ | ::= | _identifier_ []{.bar} _wildcard_ | | -| _borrow_ | ::= | ``^`` | (not allowed from _conparams_) | -|   | | | | -| _qidentifier_ | ::= | _qvarid_ []{.bar} _qidop_ []{.bar} _identifier_ | | -| _identifier_ | ::= | _varid_ []{.bar} _idop_ | | -|   | | | | -| _qoperator_ | ::= | _op_ | | -| _qconstructor_ | ::= | _conid_ []{.bar} _qconid_ | | -{.grammar .parse} - -### Statements - -| ~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _block_ | ::= | ``{`` _semis_ [_statement_ _semi_]{.many} ``}`` | | -|   | | | | -| _statement_ | ::= | _decl_ | | -| | &bar; | _withstat_ | | -| | &bar; | _withstat_ `in` _expr_ | | -| | &bar; | _returnexpr_ | | -| | &bar; | _basicexpr_ | | -|   | | | | -| _decl_ | ::= | `fun` _fundecl_ | | -| | &bar; | `val` _apattern_ `=` _blockexpr_ | (local values can use a pattern binding) | -| | &bar; | `var` _binder_ ``:=`` _blockexpr_ | | -{.grammar .parse} - -### Expressions - - -| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _blockexpr_ | ::= | _expr_ | (_block_ is interpreted as statements) | -|   | | | | -| _expr_ | ::= | _withexpr_ | | -| | | _block_ | (interpreted as ``fn(){...}``) | -| | | _returnexpr_ | | -| | | _valexpr_ | | -| | | _basicexpr_ | | -|   | | | | -| _basicexpr_ | ::= | _ifexpr_ | | -| | &bar; | _fnexpr_ | | -| | &bar; | _matchexpr_ | | -| | &bar; | _handlerexpr_ | | -| | &bar; | _opexpr_ | | -|   | | | | -| _ifexpr_ | ::= | `if` _ntlexpr_ `then` _blockexpr_ [_elif_]{.many} [`else` _blockexpr_]{.opt} | | -| | &bar; | `if` _ntlexpr_ `return` _expr_ | | -| _elif_ | ::= | `elif` _ntlexpr_ `then` _blockexpr_ | | -|   | | | | -| _matchexpr_ | ::= | `match` _ntlexpr_ `{` _semis_ [_matchrule_ _semi_]{.many} `}` | | -| _returnexpr_ | ::= | `return` _expr_ | | -| _fnexpr_ | ::= | `fn` _funbody_ | (anonymous lambda expression) | -| _valexpr_ | ::= | `val` _apattern_ `=` _blockexpr_ `in` _expr_ | | -|   | | | | -| _withexpr_ | ::= | _withstat_ `in` _expr_ | | -| _withstat_ | ::= | `with` _basicexpr_ | | -| | | `with` _binder_ `<-` _basicexpr_ | | -| | | `with` [`override`]{.opt} _heff_ _opclause_ | (with single operation) | -| | | `with` _binder_ `<-` _heff_ _opclause_ | (with named single operation) | -{.grammar .parse} - -### Operator expressions - -For simplicity, we parse all operators as if they are left associative with -the same precedence. We assume that a separate pass in the compiler will use -the fixity declarations that are in scope to properly associate all operators -in an expressions. - -| ~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _opexpr_ | ::= | _prefixexpr_ [_qoperator_ _prefixexpr_]{.many} | | -| _prefixexpr_ | ::= | [``!`` []{.bar} ``~``]{.many} _appexpr_ | | -| _appexpr_ | ::= | _appexpr_ `(` [_arguments_]{.opt} `)` | (regular application) | -| | &bar; | _appexpr_ `[` [_arguments_]{.opt} `]` | (index operation) | -| | &bar; | _appexpr_ (_fnexpr_ []{.bar} _block_) | (trailing lambda expression) | -| | &bar; | _appexpr_ `.` _atom_ | | -| | &bar; | _atom_ | | -|   | | | | -| _ntlexpr_ | ::= | _ntlprefixexpr_ [_qoperator_ _ntlprefixexpr_]{.many} | (non trailing lambda expression) | -| _ntlprefixexpr_ | ::= | [``!`` []{.bar} ``~``]{.many} _ntlappexpr_ | | -| _ntlappexpr_ | ::= | _ntlappexpr_ `(` [_arguments_]{.opt} `)` | (regular application) | -| | &bar; | _ntlappexpr_ `[` [_arguments_]{.opt} `]` | (index operation) | -| | &bar; | _ntlappexpr_ `.` _atom_ | | -| | &bar; | _atom_ | | -|   | | | | -| _arguments_ | ::= | _argument_ [`,` _argument_]{.many} | | -| _argument_ | ::= | [_identifier_ `=`]{.opt} _expr_ | | -{.grammar .parse} - - -### Atomic expressions - -| ~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _atom_ | ::= | _qidentifier_ | | -| | &bar; | _qconstructor_ | | -| | &bar; | _literal_ | | -| | &bar; | _mask_ | | -| | &bar; | `(` `)` | (unit) | -| | &bar; | `(` _annexpr_ `)` | (parenthesized expression) | -| | &bar; | `(` _annexprs_ `)` | (tuple expression) | -| | &bar; | `[` [_annexpr_ [`,` _annexprs_]{.many} [`,`]{.opt} ]{.opt} `]` | (list expression) | -|   | | | | -| _literal_ | ::= | _natural_ []{.bar} _float_ []{.bar} _char_ []{.bar} _string_ | | -| _mask_ | ::= | `mask` [`behind`]{.opt} `<` _tbasic_ `>` | | -|   | | | | -| _annexprs_ | ::= | _annexpr_ [`,` _annexpr_]{.many} | | -| _annexpr_ | ::= | _expr_ [``:`` _typescheme_]{.opt} | | -{.grammar .parse} - -### Matching - -| ~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _matchrule_ | ::= | _patterns_ [``\(&bar;\)`` _expr_]{.opt} `->` _blockexpr_ | | -|   | | | | -| _apattern_ | ::= | _pattern_ [`:` _typescheme_]{.opt} | | -| _pattern_ | ::= | _identifier_ | | -| | &bar; | _identifier_ `as` _apattern_ | (named pattern) | -| | &bar; | _qconstructor_ [`(` [_patargs_]{.opt} `)`] | | -| | &bar; | `(` [_apatterns_]{.opt} `)` | (unit, parenthesized pattern, tuple pattern) | -| | &bar; | `[` [_apatterns_]{.opt} `]` | (list pattern) | -| | &bar; | _literal_ | | -| | &bar; | _wildcard_ | | -|   | | | | -| _patterns_ | ::= | _pattern_ [`,` _pattern_]{.many} | | -| _apatterns_ | ::= | _apattern_ [`,` _apattern_]{.many} | | -| _patargs_ | ::= | _patarg_ [`,` _patarg_]{.many} | | -| _patarg_ | ::= | [_identifier_ `=`]{.opt} _apattern_ | (possibly named parameter) | -{.grammar .parse} - - -### Effect Declarations - -| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| -| _effectdecl_ | ::= | [_named_]{.opt} _effectmod_ `effect` _varid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_opdecls_]{.opt} | | -| | &bar; | [_named_]{.opt} _effectmod_ `effect` [_typeparams_]{.opt} [_kannot_]{.opt} _opdecl_ | | -| | &bar; | _named_ _effectmod_ `effect` _varid_ [_typeparams_]{.opt} [_kannot_]{.opt} `in` _type_ [_opdecls_]{.opt} | | -| _effectmod_ | ::= | [`linear`]{.opt} [`rec`]{.opt} | | -| _named_ | ::= | `named` | | -|   | | | | -| _opdecls_ | ::= | `{` _semis_ [_opdecl_ _semi_]{.many} `}` | | -| _opdecl_ | ::= | [ _pub_]{.opt} `val` _identifier_ [_typeparams_]{.opt} ``:`` _tatom_ | | -| | &bar; | [ _pub_]{.opt} (`fun` []{.bar} `ctl`) _identifier_ [_typeparams_]{.opt} _parameters_ ``:`` _tatom_ | | -{.grammar .parse} - -### Handler Expressions - -| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| -| _handlerexpr_ | ::= | [`override`]{.opt} `handler` _heff_ _opclauses_ | | -| | &bar; | [`override`]{.opt} `handle` _heff_ `(` _expr_ `)` _opclauses_ | | -| | &bar; | `named` `handler` _heff_ _opclauses_ | | -| | &bar; | `named` `handle` _heff_ `(` _expr_ `)` _opclauses_ | | -| _heff_ | ::= | [`<` _tbasic_ `>`]{.opt} | | -|   | | | | -| _opclauses_ | ::= | `{` _semis_ [_opclausex_ _semi_]{.many} `}` | | -| | | | | -| _opclausex_ | &bar; | _opclause_ | | -| | &bar; | `finally` _blockexpr_ | | -| | &bar; | `initially` `(` _oparg_ `)` _blockexpr_ | | -|   | | | | -| _opclause_ | ::= | `val` _qidentifier_ [`:` _type_]{.opt} `=` _blockexpr_ | | -| | &bar; | `fun` _qidentifier_ _opargs_ _blockexpr_ | | -| | &bar; | [_ctlmod_]{.opt}`ctl` _qidentifier_ _opargs_ _blockexpr_ | | -| | &bar; | `return` `(` _oparg_ `)` _blockexpr_ | | -| _ctlmod_ | ::= | `final` &bar; `raw` | | -|   | | | | -| _opargs_ | ::= | `(` [_oparg_ [`,` _oparg_]{.many}]{.opt} `)` | | -| _oparg_ | ::= | _paramid_ [``:`` _type_]{.opt} | | -{.grammar .parse} - -### Type schemes - -|~~~~~~~~~~~~~~|~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~|~~~| -| _typescheme_ | ::= | _somes_ _foralls_ _tarrow_ [_qualifier_]{.opt} | | | -| _type_ | ::= | _foralls_ _tarrow_ [_qualifier_]{.opt} | | | -|   | | | | | -| _foralls_ | ::= | [`forall` _typeparams_]{.opt} | | | -| _some_ | ::= | [`some` _typeparams_]{.opt} | | | -|   | | | | | -| _qualifier_ | ::= | `with` `(` _predicates_ `)` | | | -|   | | | | | -| _predicates_ | ::= | _predicate_ [`,` _predicate_]{.many} | | | -| _predicate_ | ::= | _typeapp_ | (interface) | | -{.grammar .parse} - -### Types - -|~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _tarrow_ | ::= | _tatom_ [`->` _tresult_]{.opt} | | -| _tresult_ | ::= | _tatom_ [_tbasic_]{.opt} | | -|   | | | | -| _tatom_ | ::= | _tbasic_ | | -| | &bar; | `<` _anntype_ [`,` _anntype_]{.many} [``\(&bar;\)`` _tatom_]{.opt} `>` | | -| | &bar; | `<` `>` | | -|   | | | | -| _tbasic_ | ::= | _typeapp_ | | -| | &bar; | `(` `)` | (unit type) | -| | &bar; | `(` _tparam_ `)` | (parenthesized type or type parameter) | -| | &bar; | `(` _tparam_ [`,` _tparam_]{.many} `)` | (tuple type or parameters) | -| | &bar; | `[` _anntype_ `]` | (list type) | -|   | | | | -| _typeapp_ | ::= | _typecon_ [`<` _anntype_ [`,` _anntype_]{.many} `>`]{.opt} | | -|   | | | | -| _typecon_ | ::= | _varid_ []{.bar} _qvarid_ | | -| | &bar; | _wildcard_ | | -| | &bar; | `(` `,` [`,`]{.many} `)` | (tuple constructor) | -| | &bar; | `[` `]` | (list constructor) | -| | &bar; | `(` `->` `)` | (function constructor) | -|   | | | | -| _tparam_ | ::= | [_varid_ ``:``]{.opt} _anntype_ | | -| _anntype_ | ::= | _type_ [_kannot_]{.opt} | | -{.grammar .parse} - -### Kinds - -|~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| -| _kannot_ | ::= | ``::`` _kind_ | | -|   | | | | -| _kind_ | ::= | `(` _kind_ [`,` _kind_]{.many} `)` `->` _kind_ | | -| | &bar; | _katom_ `->` _kind_ | | -| | &bar; | _katom_ | | -|   | | | | -| _katom_ | ::= | `V` | (value type) | -| | &bar; | `X` | (effect type) | -| | &bar; | `E` | (effect row) | -| | &bar; | `H` | (heap type) | -| | &bar; | `P` | (predicate type) | -| | &bar; | `S` | (scope type) | -| | &bar; | `HX` | (handled effect type) | -| | &bar; | `HX1` | (handled linear effect type) | -{.grammar .parse} - -### Implementation - -As a companion to the Flex lexical implementation, there is a full -Bison(Yacc) LALR(1) [implementation][BisonGrammar] -available. Again, the Bison parser functions -as _the_ specification of the grammar and this document should always -be in agreement with that implementation. - -[BisonGrammar]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/parser.y -[FlexLexer]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/lexer.lex -[HaskellLayout]: https://github.com/koka-lang/koka/blob/dev/src/Syntax/Layout.hs#L178 \ No newline at end of file + +# &koka; language specification + +This is the draft language specification of the &koka; language, version v&kokaversion;\ +Currently only the lexical and context-free grammar are specified. +The [standard libraries][stdlib] are documented separately. + +[stdlib]: toc.html + +## Lexical syntax + +We define the grammar and lexical syntax of the language using standard BNF +notation where non-terminals are generated by alternative patterns: + +|~~~~~~~~~~~|~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| +| _nonterm_ | ::= | _pattern_~1~ &bar; _pattern_~2~ | | +{.grammar} + +In the patterns, we use the following notations: + +|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| `terminal` | | A terminal symbol (in ASCII) | +| ``x1B`` | | A character with hexadecimal code 1B | +| ``A..F`` | | The characters from "A" to "F" (using ASCII, i.e. ``x61..x66``) | +|   | | | +| ( _pattern_ ) | | Grouping | +| [ _pattern_ ] | | Optional occurrence of _pattern_ | +| { _pattern_ } | | Zero or more occurrences of _pattern_ | +| { _pattern_ }~_n_~ | | Exactly _n_ occurrences of _pattern_ | +| _pattern_~1~ &bar; _pattern_~2~ | | Choice: either _pattern_~1~ or _pattern_~2~ | +|   | | | +| _pattern_[_diff_]{.diff} | | Difference: elements generated by _pattern_ except those in _diff_ | +| _nonterm_~[\/_lex_]~ | | Generate _nonterm_ by drawing lexemes from _lex_ | +{.grammar} + + +Care must be taken to distinguish meta-syntax such as &bar; and ) +from concrete terminal symbols as ``|`` and ``)``. In the specification +the order of the productions is not important and at each point the +_longest matching lexeme_ is preferred. For example, even though +`fun` is a reserved word, the word `functional` is considered a +single identifier. +{.grammar} + +### Source code + +Source code consists of a sequence of unicode characters. Valid characters in +actual program code consist strictly of ASCII characters which range from 0 to 127. +Only comments, string literals, and character literals are allowed to +contain extended unicode characters. The grammar is designed such that a lexical +analyzer and parser can directly work on UTF-8 encoded source files without +actually doing UTF-8 decoding or unicode category identification. + +## Lexical grammar + +In the specification of the lexical grammar all white space is explicit +and there is no implicit white space between juxtaposed symbols. The +lexical token stream is generated by the non-terminal _lex_ which +consists of lexemes and whitespace. + +Before doing lexical analysis, there is a _linefeed_ character inserted +at the start and end of the input, which makes it easier to specify line +comments and directives. + +### Lexical tokens { test } + +| ~~~~~~~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~| +| _lex_ | ::= | _lexeme_ &bar; _whitespace_ | | +| _lexeme_   | ::= | _conid_ &bar; _qconid_ | | +| | &bar; | _varid_ &bar; _qvarid_ | | +| | &bar; | _op_ &bar; _opid_ &bar; _qopid_ &bar; _wildcard_ | | +| | &bar; | _integer_ &bar; _float_ &bar; _stringlit_ &bar; _charlit_ | | +| | &bar; | _reserved_ &bar; _opreserved_ | | +| | &bar; | _special_ | | +{.grammar .lex} + +The main program consists of _whitespace_ or _lexeme_'s. The context-free +grammar will draw it's lexemes from the _lex_ production. + +### Identifiers + +|~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~| +| _anyid_ | ::= | _varid_ &bar; _qvarid_ &bar; _opid_ &bar; _qopid_ &bar; _conid_ &bar; _qconid_ | | +|   | | | | +| _qconid_ | ::= | _modulepath_ _conid_ | | +| _qvarid_ | ::= | _modulepath_ _lowerid_ | | +| _modulepath_ | ::= | _lowerid_ `/` [_lowerid_ `/`]{.many} | | +|   | | | | +| _conid_ | ::= | _upperid_ | | +| _varid_ | ::= | _lowerid_[_reserved_]{.diff} | | +|   | | | | +| _lowerid_ | ::= | _lower_ _idtail_ | | +| _upperid_ | ::= | _upper_ _idtail_ | | +| _wildcard_ | ::= | ``_`` _idtail_ | | +| _typevarid_ | ::= | _letter_ [_digit_]{.many} | | +|   | | | | +| _idtail_ | ::= | [_idchar_]{.many} [_idfinal_]{.opt} | | +| _idchar_ | ::= | _letter_ &bar; _digit_ &bar; ``_`` &bar; ``-`` | | +| _idfinal_ | ::= | [``'``]{.many} | | +|   | | | | +| _reserved_ | ::= | `infix` &bar; `infixr` &bar; `infixl` | | +| | &bar; | ``module`` &bar; `import` &bar; `as` | | +| | &bar; | ``pub`` &bar; `abstract` | | +| | &bar; | `type` &bar; `struct` &bar; `alias` &bar; `effect` &bar; `con` | | +| | &bar; | `forall` &bar; `exists` &bar; `some` | | +| | &bar; | `fun` &bar; `fn` &bar; `val` &bar; `var` &bar; `extern` | | +| | &bar; | `if` &bar; `then` &bar; `else` &bar; `elif` | | +| | &bar; | `match` &bar; `return` &bar; `with` &bar; `in` | | +| | &bar; | `handle` &bar; `handler` &bar; `mask` | | +| | &bar; | `ctl` &bar; `final` &bar; `raw` | | +| | &bar; | `override` &bar; `named` | | +| | &bar; | `interface` &bar; `break` &bar; `continue` &bar; `unsafe` | (future reserved words) | +|   | | | | +| _specialid_ | ::= | `co` &bar; `rec` &bar; `open` &bar; `extend` &bar; `behind` | | +| | &bar; | `linear` &bar; `value` &bar; `reference` | | +| | &bar; | `inline` &bar; `noinline` &bar; `initially` &bar; `finally` | | +| | &bar; | `js` &bar; `c` &bar; `cs` &bar; `file` | | +{.grammar .lex} + +Identifiers always start with a letter, may contain underscores and +dashes, and can end with prime ticks. +Like in Haskell, constructors always begin with an uppercase +letter while regular identifiers are lowercase. The rationale is to +visibly distinguish constants from variables in pattern matches. +Here are some example of valid identifiers: +```unchecked +x +concat1 +visit-left +is-nil +x' +Cons +True +``` +To avoid confusion with the subtraction operator, the occurrences of +dashes are restricted in identifiers. After lexical analysis, only +identifiers where each dash is surrounded on both sides with a _letter_ +are accepted: + +````koka +fold-right +n-1 // illegal, a digit cannot follow a dash +n - 1 // n minus 1 +n-x-1 // illegal, a digit cannot follow a dash +n-x - 1 // identifier "n-x" minus 1 +n - x - 1 // n minus x minus 1 +```` +Qualified identifiers are prefixed with a module path. Module +paths can be partial as long as they are unambiguous. + +````koka +core/map +std/core/(&) +```` + +### Operators and symbols + +| ~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| +| _qopid_ | ::= | _modulepath_ _opid_ | | +| _opid_ | ::= | `(` _symbols_ `)` | | +|   | | | | +| _op_ | ::= | _symbols_[_opreserved_ &bar; _optype_]{.diff} &bar; ``\(&bar;&bar;\)`` | | +|   | | | | +| _symbols_ | ::= | _symbol_ [_symbol_]{.many}&bar; ``/`` | | +| _symbol_ | ::= | `$` &bar; `%` &bar; ``&`` &bar; `*` &bar; `+` | | +| | &bar; | ``~`` &bar; ``!`` &bar; ``\`` &bar; `^` &bar; ``#`` | | +| | &bar; | ``=`` &bar; ``.`` &bar; ``:`` &bar; `-` &bar; `?` | | +| | &bar; | _anglebar_ | | +| _anglebar_ | ::= | ``<`` &bar; ``>`` &bar; ``\(&bar;\)`` | | +|   | | | | +| _opreserved_ | ::= | `=` &bar; `.` &bar; ``:`` &bar; `->` | | +| _optype_ | ::= | _anglebar_ _anglebar_ [_anglebar_]{.many} | | +|   | | | | +| _special_ | ::= | `{` &bar; `}` &bar; `(` &bar; `)` &bar; `[` &bar; `]` &bar; ``\(&bar;\)`` &bar; `;` &bar; `,` | | +|   | | | | +{.grammar .lex} + +### Literals + +|~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~| +| _charlit_ | ::= | ``'`` (_char_[``'`` &bar; ``\``]{.diff} &bar; _escape_) ``'`` | | +| _stringlit_ | ::= | ``"`` [_char_[``"`` &bar; ``\``]{.diff} &bar; _escape_]{.many} ``"`` | | +| | &bar; | ``r`` [``#``]{.manyn} ``"`` _rawchars_~_n_~ ``"`` [``#``]{.manyn} | (n >= 0) | +| _rawchars_~_n_~ | ::= | [_anychar_]{.many}[[_anychar_]{.many} ``"`` [``#``]{.manyn} [_anychar_]{.many}]{.diff} | | +|   | | | | +| _escape_ | ::= | ``\`` ( _charesc_ &bar; _hexesc_ ) | | +| _charesc_ | ::= | `n` &bar; `r` &bar; `t` &bar; ``\`` &bar; ``"`` &bar; ``'`` | | +| _hexesc_ | ::= | `x` [_hexdigit_]{.manyx}~2~ &bar; `u` [_hexdigit_]{.manyx}~4~ &bar; ``U`` [_hexdigit_]{.manyx}~6~ | | +|   | | | | +| _float_ | ::= | [``-``]{.opt} (decfloat &bar; hexfloat) | | +| _decfloat_ | ::= | _decimal_ (`.` _digits_ [_decexp_]{.opt} &bar; _decexp_) | | +| _decexp_ | ::= | (``e`` &bar; ``E``) _exponent_ | | +| _hexfloat_ | ::= | _hexadecimal_ (`.` _hexdigits_ [_hexexp_]{.opt} &bar; _hexexp_) | | +| _hexexp_ | ::= | (``p`` &bar; ``P``) _exponent_ | | +| _exponent_ | ::= | [``-`` &bar; ``+``]{.opt} _digit_ [_digit_]{.many} | | +|   | | | | +| _integer_ | ::= | [``-``]{.opt} (_decimal_ &bar; _hexadecimal_) | | +| _decimal_ | ::= | ``0`` &bar; _posdigit_ [[``_``]{.opt} _digits_]{.opt} | | +| _hexadecimal_ | ::= | ``0`` (``x`` &bar; ``X``) _hexdigits_ | | +| _digits_ | ::= | _digit_ [_digit_]{.many} [``_`` _digit_ [_digit_]{.many}]{.many} | | +| _hexdigits_ | ::= | _hexdigit_ [_hexdigit_]{.many} [``_`` _hexdigit_ [_hexdigit_]{.many}]{.many} | | +{.grammar .lex} + +### White space + +|~~~~~~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _whitespace_ | ::= | _white_ [_white_]{.many} &bar; _newline_ | | +| _white_ | ::= | _space_ | | +| | &bar; | _linecomment_ &bar; _blockcomment_ | | +| | &bar; | _linedirective_ | | +|   | | | | +| _linecomment_ | ::= | ``//`` [_char_ &bar; _tab_]{.many} | | +| _linedirective_ | ::= | _newline_ ``#`` [_char_ &bar; _tab_]{.many} | | +|   | | | | +| _blockcomment_ | ::= | /* _blockpart_ [_blockcomment_ _blockpart_]{.many} */ | (allows nested comments) | +| _blockpart_ | ::= | [_anychar_]{.many}[[_anychar_]{.many}\ (/*&bar;*/)\ [_anychar_]{.many}]{.diff} | | +{.grammar .lex} + +### Character classes + +|~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _letter_ | ::= | _upper_ &bar; _lower_ | | +| _upper_ | ::= | ``A..Z`` | (i.e. ``x41..x5A``) | +| _lower_ | ::= | ``a..z`` | (i.e. ``x61..x7A``) | +| _digit_ | ::= | ``0..9`` | (i.e. ``x30..x39``) | +| _posdigit_ | ::= | ``1..9`` | | +| _hexdigit_ | ::= | ``a..f`` &bar; ``A..F`` &bar; _digit_ | | +|   | | | | +| _anychar_ | ::= | _char_ &bar; _tab_ &bar; _newline_ | (in comments and raw strings) | +| _newline_ | ::= | [_return_]{.opt} _linefeed_ | (windows or unix style end of line) | +|   | | | | +| _space_ | ::= | ``x20`` | (a space) | +| _tab_ | ::= | ``x09`` | (a tab (``\t``)) | +| _linefeed_ | ::= | ``x0A`` | (a line feed (``\n``)) | +| _return_ | ::= | ``x0D`` | (a carriage return (``\r``)) | +|   | | | | +| _char_ | ::= | _unicode_[_control_ &bar; _surrogate_ &bar; _bidi_]{.diff} | (includes _space_) | +| _unicode_ | ::= | ``x00..x10FFFF`` | | +| _control_ | ::= | ``x00..x1F`` &bar; ``x7F`` &bar; ``x80..9F`` | (C0, DEL, and C1) | +| _surrogate_| ::= | ``xD800..xDFFF`` | | +| _bidi_ | ::= | ``x200E`` &bar; ``x200F`` &bar; ``x202A..x202E`` &bar; ``x2066..x2069`` | (bi-directional text control) | +{.grammar .lex} + +Actual program code consists only of 7-bit ASCII characters while only comments +and literals can contain extended unicode characters. As such, +a lexical analyzer can directly process UTF-8 encoded input as +a sequence of bytes without needing UTF-8 decoding or unicode character +classification[^fn-utf8]. +For security +[@Boucher:trojan], some character ranges are excluded: the C0 and C1 +[control codes](https://en.wikipedia.org/wiki/C0_and_C1_control_codes) (except for space, +tab, carriage return, and line feeds), surrogate characters, and bi-directional +text control characters. + + +[^fn-utf8]: This is used for example in the [Flex][FlexLexer] implementation. + In particular, we only need to adapt the _char_ definition: + + |~~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| + | _char_ | ::= | _unicode_[_control_ &bar; _surrogate_ &bar; _bidi_]{.diff} | | + | _unicode_ | ::= | ``x00..x7F`` | (ASCII) | + | | &bar; | (``xC2..xDF``) _cont_ | | + | | &bar; | ``xE0`` (``xA0..xBF``) _cont_ | (exclude overlong encodings) | + | | &bar; | (``xE1..xEF``) _cont_ _cont_ | | + | | &bar; | ``xF0`` (``x90..xBF``) _cont_ _cont_ | (exclude overlong encodings) | + | | &bar; | (``xF1..xF3``) _cont_ _cont_ _cont_ | | + | | &bar; | ``xF4`` (``x80..x8F``) _cont_ _cont_ | (no codepoint larger than ``x10FFFF``) | + | _cont_ | ::= | ``x80..xBF`` | | + | _surrogate_| ::= | ``xED`` (``xA0..xBF``) _cont_ | | + | _control_ | ::= | ``x00..x1F`` | + | | &bar; | ``x7F`` | | + | | &bar; | ``xC2`` (``x80..x9F``) | | + | _bidi_ | ::= | ``xE2`` ``0x80`` (``0x8E..0x8F``) | (left-to-right mark (``u200E``) and right-to-left mark (``u200F``)) | + | | &bar; | ``xE2`` ``0x80`` (``0xAA..0xAE``) | (left-to-right embedding (``u202A``) up to right-to-left override (``u202E``)) | + | | &bar; | ``xE2`` ``0x81`` (``0xA6..0xA9``) | (left-to-right isolate (``u2066``) up to pop directional isolate (``u2069``))| + {.grammar .lex} + + +[utf8unsafe]: https://arxiv.org/pdf/2111.00169.pdf +[bidi]: https://en.wikipedia.org/wiki/Bidirectional_text + +## Layout {#sec-layout} + +[Haskell]: http://www.haskell.org/onlinereport/haskell2010/haskellch10.html#x17-17800010.3 +[Python]: http://docs.python.org/2/reference/lexical_analysis.html +[JavaScript]: https://tc39.github.io/ecma262/#sec-rules-of-automatic-semicolon-insertion +[Scala]: http://www.scala-lang.org/old/sites/default/files/linuxsoft_archives/docu/files/ScalaReference.pdf#page=13 +[Go]: http://golang.org/ref/spec#Semicolons + + +Just like programming languages like +[Haskell], [Python], [JavaScript], [Scala], [Go], etc., there is a layout rule +which automatically adds braces and semicolons at appropriate places: + +* Any block that is _indented_ is automatically wrapped with curly braces: + ``` + fun show-messages1( msgs : list ) : console () + msgs.foreach fn(msg) + println(msg) + ``` + is elaborated to: + ```unchecked + fun show-messages1( msgs : list ) : console () { + msgs.foreach fn(msg) { + println(msg) + } + } + ``` + +* Any statements and declarations that are _aligned_ in a block are terminated with semicolons, that is: + ``` + fun show-messages2( msgs : list ) : console () + msgs.foreach fn(msg) + println(msg) + println("--") + println("done") + ``` + is fully elaborated to: + ```unchecked + fun show-messages2( msgs : list ) : console () { + msgs.foreach fn(msg){ + println(msg); + println("--"); + }; + println("done"); + } + ``` + +* Long expressions or declarations can still be indented without getting braces or semicolons + if it is clear from the start- or previous token that the line continues + an expression or declaration. Here is a contrived example: + ``` + fun eq2( x : int, + y : int ) : io bool + print("calc " ++ + "equ" ++ + "ality") + val result = if (x == y) + then True + else False + result + ``` + is elaborated to: + ```unchecked + fun eq2( x : int, + y : int ) : io bool { + print("calc " ++ + "equ" ++ + "ality"); + val result = if (x == y) + then True + else False; + result + } + ``` + Here the long string expression is indented but no braces or semicolons + are inserted as the previous lines end with an operator (`++`). + Similarly, in the `if` expression no braces or semicolons are inserted + as the indented lines start with `then` and `else` respectively. + In the parameter declaration, the `,` signifies the continuation. + More precisely, for long expressions and declarations, indented or aligned lines + do not get braced or semicolons if: + + 1. The line starts with a clear expression or declaration _start continuation token_, + namely: an operator (including `.`), `then`, `else`, `elif`, + a closing brace (`)`, `>`, `]`, or `}`), + or one of `,`, `->`, `{` , `=`, `|`, `::`, `.`, `:=`. + 2. The previous line ends with a clear expression or declaration _end continuation token_, + namely an operator (including `.`), an open brace (`(`, `<`, `[`, or `{`), or `,`. + +The layout algorithm is performed on the token stream in-between lexing +and parsing, and is independent of both. In particular, there are no intricate +dependencies with the parser (which leads to very complex layout rules, as is the +case in languages like [Haskell] or [JavaScript]). + +Moreover, in contrast to purely token-based layout rules (as in [Scala] or [Go] for example), +the visual indentation in a Koka program corresponds directly to how the compiler +interprets the statements. Many tricky layout +examples in other programming languages are often based on a mismatch between +the visual representation and how a compiler interprets the tokens -- with +&koka;'s layout rule such issues are largely avoided. + +Of course, it is still allowed to explicitly use semicolons and braces, +which can be used for example to put multiple statements on a single line: + +``` +fun equal-line( x : int, y : int ) : io bool { + print("calculate equality"); (x == y) +} +``` + +The layout algorithm also checks for invalid layouts where the layout would +not visually correspond to how the compiler interprets the tokens. In +particular, it is illegal to indent less than the layout context or to put +comments into the indentation (because of tabs or potential unicode +characters). For example, the program: + +```unchecked +fun equal( x : int, y : int ) : io bool { + print("calculate equality") + result = if (x == y) then True // wrong: too little indentation + /* wrong */ else False + result +} +``` + +is rejected. In order to facilitate code generation or source code +compression, compilers are also required to support a mode where the layout +rule is not applied and no braces or semicolons are inserted. A recognized command +line flag for that mode should be ``--nolayout``. + +### The layout algorithm + +To define the layout algorithm formally, we first establish some terminology: + +* A new line is started after every _linefeed_ character. +* Any non-_white_ token is called a _lexeme_, where a line without lexemes + is called _blank_. +* The indentation of a lexeme is the column number of its first character on + that line (starting at 1), and the indentation of a line is the indentation + of the first lexeme on the line. +* A lexeme is an _expression continuation_ if it is the first lexeme on a line, + and the lexeme is a _start continuation token_, or the previous lexeme is an + _end continuation token_ (as defined in the previous section). + +Because braces can be nested, we use a _layout stack_ of strictly +increasing indentations. The top indentation on the layout stack holds the +_layout indentation_. The initial layout stack contains the single +value 0 (which is never popped). We now proceed through the token stream +where we perform the following operations in order: first brace insertion, +then layout stack operations, and finally semicolon insertion: + +* _Brace insertion_: For each non-blank line, consider the first lexeme on the line. + If the indentation is larger than the layout indentation, and the lexeme + is not an _expression continuation_, then insert an open brace `{` before the lexeme. + If the indention is less than the layout indentation, and the lexeme is not already a + closing brace, insert a closing brace `}` before the lexeme. + +* _Layout stack operations_: If the previous lexeme was an + open brace `{` or the start of the lexical token sequence, we push the + indentation of the current lexeme on the layout stack. The pushed indentation + must be larger than the previous layout indentation (unless the current lexeme + is a closing brace). When a closing brace `}` is encountered the top + indentation is popped from the layout stack. + +* _Semicolon insertion_: For each non-blank line, the + indentation must be equal or larger to the layout indentation. + If the indentation is equal to the layout indentation, and the first + lexeme on the line is not an _expression continuation_, a semicolon + is inserted before the lexeme. + Also, a semicolon is always inserted before a closing brace `}` and + before the end of the token sequence. +{.grammar} + +As defined, braces are inserted around any indented blocks, semicolons +are inserted whenever statements or declarations are +aligned (unless the lexeme happens to be a clear expression continuation). To +simplify the grammar specification, a semicolon is also always inserted before +a closing brace and the end of the source. This allows us to specify many +grammar elements as ended by semicolons instead of separated by semicolons +which is more difficult to specify for a LALR(1) grammar. + +The layout can be implemented as a separate transformation on the lexical token +stream (see the 50 line [Haskell][HaskellLayout] implementation in the Koka compiler), +or directly as part of the lexer (see the [Flex][FlexLexer] implementation) + +### Implementation { #sec:lex-implementation } + +There is a full [Flex (Lex) implementation][FlexLexer] of lexical +analysis and the layout algorithm. +Ultimately, the Flex implementation serves as _the_ +specification, and this document and the Flex implementation should +always be in agreement. + +## Context-free syntax + +The grammar specification starts with the non terminal _module_ which draws +its lexical tokens from _lex_ where all _whitespace_ tokens are implicitly +ignored. + +### Modules + +|~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| +| _module_~[_lex_]{.opt}~ | ::= | [_moduledecl_]{.opt} _modulebody_ | | +|   | | | | +| _moduledecl_ | ::= | _semis_ `module` _moduleid_ | | +| _moduleid_ | ::= | _qvarid_ &bar; _varid_ | | +|   | | | | +| _modulebody_ | ::= | `{` _semis_ _declarations_ `}` _semis_ | | +| | &bar; | _semis_ _declarations_ | | +|   | | | | +| _semis_ | ::= | [`;`]{.many} | | +| _semi_ | ::= | `;` _semis_ | | +{.grammar .parse} + +### Top level declarations + +|~~~~~~~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~| +| _declarations_ | ::= | [_importdecl_]{.many} [_fixitydecl_]{.many} _topdecls_ | | +|   | | | | +| _importdecl_ | ::= | [ _pub_]{.opt} `import` [_moduleid_ `=`]{.opt} _moduleid_ _semi_ | | +|   | | | | +| _fixitydecl_ | ::= | [ _pub_]{.opt} _fixity_ _integer_ _identifier_ [`,` _identifier_]{.many} _semi_ | | +| _fixity_ | ::= | `infixl` &bar; `infixr` &bar; `infix` | | +|   | | | | +| _topdecls_ | ::= | [_topdecl_ _semi_]{.many} | | +| _topdecl_ | ::= | [ _pub_]{.opt} _puredecl_ | | +| | &bar; | [ _pub_]{.opt} _aliasdecl_ | | +| | &bar; | [ _pub_]{.opt} _externdecl_ | | +| | &bar; | [ _pubabstract_]{.opt} _typedecl_ | | +| | &bar; | [ _pubabstract_]{.opt} _effectdecl_ | | +|   | | | | +| _pub_ | ::= | `pub` | | +| _pubabstract_ | ::= | `pub` &bar; `abstract` | | +{.grammar .parse} + +### Type Declarations + +| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| +| _aliasdecl_ | ::= | `alias` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} `=` _type_ | | +|   | | | | +| _typedecl_ | ::= | _typemod_ `type` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_typebody_]{.opt} | | +| | &bar; | _structmod_ `struct` _typeid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_conparams_]{.opt} | | +|   | | | | +| _typemod_ | ::= | `co` &bar; `rec` &bar; `open` &bar; `extend` &bar; _structmod_ | | +| _structmod_ | ::= | `value` &bar; `reference` | | +|   | | | | +| _typeid_ | ::= | _varid_ &bar; ``[]`` &bar; `(` [`,`]{.many} `)` &bar; `<` `>` &bar; `<` [&bar;]{.koka; .code} `>` | | +|   | | | | +| _typeparams_ | ::= | `<` [_tbinders_]{.opt} `>` | | +| _tbinders_ | ::= | _tbinder_ [`,` _tbinder_]{.many} | | +| _tbinder_ | ::= | _varid_ [_kannot_]{.opt} | | +| _typebody_ | ::= | `{` _semis_ [_constructor_ _semi_]{.many} `}` | | +|   | | | | +| _constructor_ | ::= | [ _pub_]{.opt} [`con`]{.opt} _conid_ [_typeparams_]{.opt} [_conparams_]{.opt} | | +| _conparams_ | ::= | `{` _semis_ [_parameter_ _semi_]{.many} `}` | | +{.grammar .parse} + +### Value and Function Declarations + +| ~~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~| +| _puredecl_ | ::= | [_inlinemod_]{.opt} `val` _valdecl_ | | +| | &bar; | [_inlinemod_]{.opt} `fun` _fundecl_ | | +| _inlinemod_ | ::= | `inline` &bar; `noinline` | | +|   | | | | +| _valdecl_ | ::= | _binder_ `=` _blockexpr_ | | +| _binder_ | ::= | _identifier_ [``:`` _type_]{.opt} | | +|   | | | | +| _fundecl_ | ::= | _funid_ _funbody_ | | +| _funbody_ | ::= | _funparam_ _blockexpr_ | | +| _funparam_ | ::= | [_typeparams_]{.opt} _pparameters_ [``:`` _tresult_]{.opt} [_qualifier_]{.opt} | | +| _funid_ | ::= | _identifier_ | | +| | &bar; | ``[`` [`,`]{.many} ``]`` | (indexing operator) | +|   | | | | +| _parameters_ | ::= | `(` [_parameter_ [`,` _parameter_]{.many}]{.opt} `)` | | +| _parameter_ | ::= | [_borrow_]{.opt} _paramid_ [``:`` _type_]{.opt} [`=` _expr_]{.opt} | | +|   | | | | +| _pparameters_ | ::= | `(` [_pparameter_ [`,` _pparameter_]{.many}]{.opt} `)` | (pattern matching parameters) | +| _pparameter_ | ::= | [_borrow_]{.opt} _pattern_ [``:`` _type_]{.opt} [`=` _expr_]{.opt} | | +|   | | | | +| _paramid_ | ::= | _identifier_ &bar; _wildcard_ | | +| _borrow_ | ::= | ``^`` | (not allowed from _conparams_) | +|   | | | | +| _qidentifier_ | ::= | _qvarid_ &bar; _qidop_ &bar; _identifier_ | | +| _identifier_ | ::= | _varid_ &bar; _idop_ | | +|   | | | | +| _qoperator_ | ::= | _op_ | | +| _qconstructor_ | ::= | _conid_ &bar; _qconid_ | | +{.grammar .parse} + +### Statements + +| ~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _block_ | ::= | ``{`` _semis_ [_statement_ _semi_]{.many} ``}`` | | +|   | | | | +| _statement_ | ::= | _decl_ | | +| | &bar; | _withstat_ | | +| | &bar; | _withstat_ `in` _expr_ | | +| | &bar; | _returnexpr_ | | +| | &bar; | _basicexpr_ | | +|   | | | | +| _decl_ | ::= | `fun` _fundecl_ | | +| | &bar; | `val` _apattern_ `=` _blockexpr_ | (local values can use a pattern binding) | +| | &bar; | `var` _binder_ ``:=`` _blockexpr_ | | +{.grammar .parse} + +### Expressions + + +| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _blockexpr_ | ::= | _expr_ | (_block_ is interpreted as statements) | +|   | | | | +| _expr_ | ::= | _withexpr_ | | +| | | _block_ | (interpreted as ``fn(){...}``) | +| | | _returnexpr_ | | +| | | _valexpr_ | | +| | | _basicexpr_ | | +|   | | | | +| _basicexpr_ | ::= | _ifexpr_ | | +| | &bar; | _fnexpr_ | | +| | &bar; | _matchexpr_ | | +| | &bar; | _handlerexpr_ | | +| | &bar; | _opexpr_ | | +|   | | | | +| _ifexpr_ | ::= | `if` _ntlexpr_ `then` _blockexpr_ [_elif_]{.many} [`else` _blockexpr_]{.opt} | | +| | &bar; | `if` _ntlexpr_ `return` _expr_ | | +| _elif_ | ::= | `elif` _ntlexpr_ `then` _blockexpr_ | | +|   | | | | +| _matchexpr_ | ::= | `match` _ntlexpr_ `{` _semis_ [_matchrule_ _semi_]{.many} `}` | | +| _returnexpr_ | ::= | `return` _expr_ | | +| _fnexpr_ | ::= | `fn` _funbody_ | (anonymous lambda expression) | +| _valexpr_ | ::= | `val` _apattern_ `=` _blockexpr_ `in` _expr_ | | +|   | | | | +| _withexpr_ | ::= | _withstat_ `in` _expr_ | | +| _withstat_ | ::= | `with` _basicexpr_ | | +| | | `with` _binder_ `<-` _basicexpr_ | | +| | | `with` [`override`]{.opt} _heff_ _opclause_ | (with single operation) | +| | | `with` _binder_ `<-` _heff_ _opclause_ | (with named single operation) | +{.grammar .parse} + +### Operator expressions + +For simplicity, we parse all operators as if they are left associative with +the same precedence. We assume that a separate pass in the compiler will use +the fixity declarations that are in scope to properly associate all operators +in an expressions. + +| ~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _opexpr_ | ::= | _prefixexpr_ [_qoperator_ _prefixexpr_]{.many} | | +| _prefixexpr_ | ::= | [``!`` &bar; ``~``]{.many} _appexpr_ | | +| _appexpr_ | ::= | _appexpr_ `(` [_arguments_]{.opt} `)` | (regular application) | +| | &bar; | _appexpr_ `[` [_arguments_]{.opt} `]` | (index operation) | +| | &bar; | _appexpr_ (_fnexpr_ &bar; _block_) | (trailing lambda expression) | +| | &bar; | _appexpr_ `.` _atom_ | | +| | &bar; | _atom_ | | +|   | | | | +| _ntlexpr_ | ::= | _ntlprefixexpr_ [_qoperator_ _ntlprefixexpr_]{.many} | (non trailing lambda expression) | +| _ntlprefixexpr_ | ::= | [``!`` &bar; ``~``]{.many} _ntlappexpr_ | | +| _ntlappexpr_ | ::= | _ntlappexpr_ `(` [_arguments_]{.opt} `)` | (regular application) | +| | &bar; | _ntlappexpr_ `[` [_arguments_]{.opt} `]` | (index operation) | +| | &bar; | _ntlappexpr_ `.` _atom_ | | +| | &bar; | _atom_ | | +|   | | | | +| _arguments_ | ::= | _argument_ [`,` _argument_]{.many} | | +| _argument_ | ::= | [_identifier_ `=`]{.opt} _expr_ | | +{.grammar .parse} + + +### Atomic expressions + +| ~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _atom_ | ::= | _qidentifier_ | | +| | &bar; | _qconstructor_ | | +| | &bar; | _literal_ | | +| | &bar; | _mask_ | | +| | &bar; | `(` `)` | (unit) | +| | &bar; | `(` _annexpr_ `)` | (parenthesized expression) | +| | &bar; | `(` _annexprs_ `)` | (tuple expression) | +| | &bar; | `[` [_annexpr_ [`,` _annexprs_]{.many} [`,`]{.opt} ]{.opt} `]` | (list expression) | +|   | | | | +| _literal_ | ::= | _natural_ &bar; _float_ &bar; _charlit_ &bar; _stringlit_ | | +| _mask_ | ::= | `mask` [`behind`]{.opt} `<` _tbasic_ `>` | | +|   | | | | +| _annexprs_ | ::= | _annexpr_ [`,` _annexpr_]{.many} | | +| _annexpr_ | ::= | _expr_ [``:`` _typescheme_]{.opt} | | +{.grammar .parse} + +### Matching + +| ~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _matchrule_ | ::= | _patterns_ [``\(&bar;\)`` _expr_]{.opt} `->` _blockexpr_ | | +|   | | | | +| _apattern_ | ::= | _pattern_ [`:` _typescheme_]{.opt} | | +| _pattern_ | ::= | _identifier_ | | +| | &bar; | _identifier_ `as` _apattern_ | (named pattern) | +| | &bar; | _qconstructor_ [`(` [_patargs_]{.opt} `)`] | | +| | &bar; | `(` [_apatterns_]{.opt} `)` | (unit, parenthesized pattern, tuple pattern) | +| | &bar; | `[` [_apatterns_]{.opt} `]` | (list pattern) | +| | &bar; | _literal_ | | +| | &bar; | _wildcard_ | | +|   | | | | +| _patterns_ | ::= | _pattern_ [`,` _pattern_]{.many} | | +| _apatterns_ | ::= | _apattern_ [`,` _apattern_]{.many} | | +| _patargs_ | ::= | _patarg_ [`,` _patarg_]{.many} | | +| _patarg_ | ::= | [_identifier_ `=`]{.opt} _apattern_ | (possibly named parameter) | +{.grammar .parse} + + +### Effect Declarations + +| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| +| _effectdecl_ | ::= | [_named_]{.opt} _effectmod_ `effect` _varid_ [_typeparams_]{.opt} [_kannot_]{.opt} [_opdecls_]{.opt} | | +| | &bar; | [_named_]{.opt} _effectmod_ `effect` [_typeparams_]{.opt} [_kannot_]{.opt} _opdecl_ | | +| | &bar; | _named_ _effectmod_ `effect` _varid_ [_typeparams_]{.opt} [_kannot_]{.opt} `in` _type_ [_opdecls_]{.opt} | | +| _effectmod_ | ::= | [`linear`]{.opt} [`rec`]{.opt} | | +| _named_ | ::= | `named` | | +|   | | | | +| _opdecls_ | ::= | `{` _semis_ [_opdecl_ _semi_]{.many} `}` | | +| _opdecl_ | ::= | [ _pub_]{.opt} `val` _identifier_ [_typeparams_]{.opt} ``:`` _tatom_ | | +| | &bar; | [ _pub_]{.opt} (`fun` &bar; `ctl`) _identifier_ [_typeparams_]{.opt} _parameters_ ``:`` _tatom_ | | +{.grammar .parse} + +### Handler Expressions + +| ~~~~~~~~~~~~~~| ~~~~~~| ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| ~~~| +| _handlerexpr_ | ::= | [`override`]{.opt} `handler` _heff_ _opclauses_ | | +| | &bar; | [`override`]{.opt} `handle` _heff_ `(` _expr_ `)` _opclauses_ | | +| | &bar; | `named` `handler` _heff_ _opclauses_ | | +| | &bar; | `named` `handle` _heff_ `(` _expr_ `)` _opclauses_ | | +| _heff_ | ::= | [`<` _tbasic_ `>`]{.opt} | | +|   | | | | +| _opclauses_ | ::= | `{` _semis_ [_opclausex_ _semi_]{.many} `}` | | +| | | | | +| _opclausex_ | &bar; | _opclause_ | | +| | &bar; | `finally` _blockexpr_ | | +| | &bar; | `initially` `(` _oparg_ `)` _blockexpr_ | | +|   | | | | +| _opclause_ | ::= | `val` _qidentifier_ [`:` _type_]{.opt} `=` _blockexpr_ | | +| | &bar; | `fun` _qidentifier_ _opargs_ _blockexpr_ | | +| | &bar; | [_ctlmod_]{.opt}`ctl` _qidentifier_ _opargs_ _blockexpr_ | | +| | &bar; | `return` `(` _oparg_ `)` _blockexpr_ | | +| _ctlmod_ | ::= | `final` &bar; `raw` | | +|   | | | | +| _opargs_ | ::= | `(` [_oparg_ [`,` _oparg_]{.many}]{.opt} `)` | | +| _oparg_ | ::= | _paramid_ [``:`` _type_]{.opt} | | +{.grammar .parse} + +### Type schemes + +|~~~~~~~~~~~~~~|~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~|~~~| +| _typescheme_ | ::= | _somes_ _foralls_ _tarrow_ [_qualifier_]{.opt} | | | +| _type_ | ::= | _foralls_ _tarrow_ [_qualifier_]{.opt} | | | +|   | | | | | +| _foralls_ | ::= | [`forall` _typeparams_]{.opt} | | | +| _some_ | ::= | [`some` _typeparams_]{.opt} | | | +|   | | | | | +| _qualifier_ | ::= | `with` `(` _predicates_ `)` | | | +|   | | | | | +| _predicates_ | ::= | _predicate_ [`,` _predicate_]{.many} | | | +| _predicate_ | ::= | _typeapp_ | (interface) | | +{.grammar .parse} + +### Types + +|~~~~~~~~~~~|~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _tarrow_ | ::= | _tatom_ [`->` _tresult_]{.opt} | | +| _tresult_ | ::= | _tatom_ [_tbasic_]{.opt} | | +|   | | | | +| _tatom_ | ::= | _tbasic_ | | +| | &bar; | `<` _anntype_ [`,` _anntype_]{.many} [``\(&bar;\)`` _tatom_]{.opt} `>` | | +| | &bar; | `<` `>` | | +|   | | | | +| _tbasic_ | ::= | _typeapp_ | | +| | &bar; | `(` `)` | (unit type) | +| | &bar; | `(` _tparam_ `)` | (parenthesized type or type parameter) | +| | &bar; | `(` _tparam_ [`,` _tparam_]{.many} `)` | (tuple type or parameters) | +| | &bar; | `[` _anntype_ `]` | (list type) | +|   | | | | +| _typeapp_ | ::= | _typecon_ [`<` _anntype_ [`,` _anntype_]{.many} `>`]{.opt} | | +|   | | | | +| _typecon_ | ::= | _varid_ &bar; _qvarid_ | | +| | &bar; | _wildcard_ | | +| | &bar; | `(` `,` [`,`]{.many} `)` | (tuple constructor) | +| | &bar; | `[` `]` | (list constructor) | +| | &bar; | `(` `->` `)` | (function constructor) | +|   | | | | +| _tparam_ | ::= | [_varid_ ``:``]{.opt} _anntype_ | | +| _anntype_ | ::= | _type_ [_kannot_]{.opt} | | +{.grammar .parse} + +### Kinds + +|~~~~~~~~~~|~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~| +| _kannot_ | ::= | ``::`` _kind_ | | +|   | | | | +| _kind_ | ::= | `(` _kind_ [`,` _kind_]{.many} `)` `->` _kind_ | | +| | &bar; | _katom_ `->` _kind_ | | +| | &bar; | _katom_ | | +|   | | | | +| _katom_ | ::= | `V` | (value type) | +| | &bar; | `X` | (effect type) | +| | &bar; | `E` | (effect row) | +| | &bar; | `H` | (heap type) | +| | &bar; | `P` | (predicate type) | +| | &bar; | `S` | (scope type) | +| | &bar; | `HX` | (handled effect type) | +| | &bar; | `HX1` | (handled linear effect type) | +{.grammar .parse} + +### Implementation + +As a companion to the Flex lexical implementation, there is a full +Bison(Yacc) LALR(1) [implementation][BisonGrammar] +available. Again, the Bison parser functions +as _the_ specification of the grammar and this document should always +be in agreement with that implementation. + +[BisonGrammar]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/parser.y +[FlexLexer]: https://github.com/koka-lang/koka/blob/master/doc/spec/grammar/lexer.l +[HaskellLayout]: https://github.com/koka-lang/koka/blob/dev/src/Syntax/Layout.hs#L181 \ No newline at end of file diff --git a/doc/spec/styles/book.css b/doc/spec/styles/book.css index c304a4569..d8d20c1b6 100644 --- a/doc/spec/styles/book.css +++ b/doc/spec/styles/book.css @@ -78,9 +78,6 @@ table.grammar { padding: 0pt; } -.grammar .bar { - padding: 0ex 0.5ex; -} .grammar td:nth-child(2) { font-style: normal; @@ -112,10 +109,13 @@ table .kw, table .tp, table .co, font-style: italic; } -.opt, .many { +.opt, .many, .manyn { padding: 0ex 0.5ex; } +.manyx { + padding-left: 0.5ex; +} #toc { display: none; diff --git a/kklib/ide/vs2022/kklib-test-effbayes.vcxproj b/kklib/ide/vs2022/kklib-test-effbayes.vcxproj new file mode 100644 index 000000000..73397df91 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test-effbayes.vcxproj @@ -0,0 +1,199 @@ + + + + + Debug + Win32 + + + Release + Win32 + + + Debug + x64 + + + Release + x64 + + + + 15.0 + {FEF78591-750E-4C21-A04D-22707CC66878} + kklibtesti + 10.0 + kklib-test-effbayes + + + + Application + true + v143 + + + Application + false + v143 + true + + + Application + true + v143 + + + Application + false + v143 + true + + + + + + + + + + + + + + + + + + + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + CompileAsCpp + + + Console + + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + false + KK_DEBUG_FULL=1;KK_STATIC_LIB=1;KK_MIMALLOC=1; + Strict + CompileAsCpp + + + Console + kernel32.lib;user32.lib;%(AdditionalDependencies) + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + _MBCS;%(PreprocessorDefinitions);NDEBUG + stdcpp17 + CompileAsCpp + + + true + true + Console + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + NDEBUG=1;KK_STATIC_LIB=1;KK_MIMALLOC=1;_MBCS;%(PreprocessorDefinitions);NDEBUG + stdcpp17 + true + Strict + CompileAsCpp + + + true + true + Console + UseFastLinkTimeCodeGeneration + + + + + {abb5eae7-b3e6-432e-b636-333449892ea6} + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib-test-effbayes.vcxproj.filters b/kklib/ide/vs2022/kklib-test-effbayes.vcxproj.filters new file mode 100644 index 000000000..9308566b8 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test-effbayes.vcxproj.filters @@ -0,0 +1,36 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj b/kklib/ide/vs2022/kklib-test-interactive.vcxproj new file mode 100644 index 000000000..56dce2689 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj @@ -0,0 +1,182 @@ + + + + + Debug + Win32 + + + Release + Win32 + + + Debug + x64 + + + Release + x64 + + + + 15.0 + {FEF78590-750E-4C21-A04D-22707CC66878} + kklibtesti + 10.0 + kklib-test-interactive + + + + Application + true + v143 + + + Application + false + v143 + true + + + Application + true + v143 + + + Application + false + v143 + true + + + + + + + + + + + + + + + + + + + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + CompileAsCpp + KK_DEBUG_FULL=1;KK_STATIC_LIB=1;KK_MIMALLOC=1; + + + Console + + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + true + KK_DEBUG_FULL=1;KK_STATIC_LIB=1;KK_MIMALLOC=1; + Strict + CompileAsCpp + + + Console + kernel32.lib;user32.lib;%(AdditionalDependencies) + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + NDEBUG=1;KK_STATIC_LIB=1;KK_MIMALLOC=1;_MBCS;%(PreprocessorDefinitions) + stdcpp17 + CompileAsCpp + false + false + + + true + true + Console + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + NDEBUG=1;KK_STATIC_LIB=1;KK_MIMALLOC=1;_MBCS;%(PreprocessorDefinitions);NDEBUG + stdcpp17 + true + Strict + CompileAsCpp + + + true + true + Console + UseFastLinkTimeCodeGeneration + + + + + {abb5eae7-b3e6-432e-b636-333449892ea6} + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters new file mode 100644 index 000000000..62586dda1 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test-interactive.vcxproj.filters @@ -0,0 +1,16 @@ + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib-test.vcxproj b/kklib/ide/vs2022/kklib-test.vcxproj new file mode 100644 index 000000000..611e669a1 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test.vcxproj @@ -0,0 +1,172 @@ + + + + + Debug + Win32 + + + Release + Win32 + + + Debug + x64 + + + Release + x64 + + + + 15.0 + {FEF7858F-750E-4C21-A04D-22707CC66878} + kklibtest + 10.0 + kklib-test + + + + Application + true + v143 + + + Application + false + v143 + true + + + Application + true + v143 + + + Application + false + v143 + true + + + + + + + + + + + + + + + + + + + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + $(ProjectDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(ProjectDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + CompileAsCpp + + + Console + + + + + Level3 + Disabled + true + true + ..\..\include + stdcpp17 + KK_STATIC_LIB=1;KK_MIMALLOC=1; + CompileAsCpp + + + Console + kernel32.lib;user32.lib;%(AdditionalDependencies) + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + _MBCS;%(PreprocessorDefinitions);NDEBUG + stdcpp17 + CompileAsCpp + + + true + true + Console + + + + + Level3 + MaxSpeed + true + true + true + true + ..\..\include + KK_STATIC_LIB=1;KK_MIMALLOC=1;_MBCS;%(PreprocessorDefinitions);NDEBUG + stdcpp17 + false + CompileAsCpp + + + true + true + Console + + + + + AssemblyAndSourceCode + AssemblyAndSourceCode + + + + + + {abb5eae7-b3e6-432e-b636-333449892ea6} + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib-test.vcxproj.filters b/kklib/ide/vs2022/kklib-test.vcxproj.filters new file mode 100644 index 000000000..457c09591 --- /dev/null +++ b/kklib/ide/vs2022/kklib-test.vcxproj.filters @@ -0,0 +1,21 @@ + + + + + {cfad405d-6bd1-44d5-9731-40fc308f3cfd} + + + + + Source Files + + + Source Files + + + + + Source Files + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib.natvis b/kklib/ide/vs2022/kklib.natvis new file mode 100644 index 000000000..1e65cd8cd --- /dev/null +++ b/kklib/ide/vs2022/kklib.natvis @@ -0,0 +1,140 @@ + + + + bigint, rc={((kk_bigint_s*)ibox)->_block.header.refcount} + small int= {((intptr_t)ibox)/4} + + ((kk_bigint_s*)ibox) + + + + + + + + + + + diff --git a/kklib/ide/vs2022/kklib.sln b/kklib/ide/vs2022/kklib.sln new file mode 100644 index 000000000..e6d506e69 --- /dev/null +++ b/kklib/ide/vs2022/kklib.sln @@ -0,0 +1,58 @@ +Microsoft Visual Studio Solution File, Format Version 12.00 +# Visual Studio Version 16 +VisualStudioVersion = 16.0.30204.135 +MinimumVisualStudioVersion = 10.0.40219.1 +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "kklib", "kklib.vcxproj", "{ABB5EAE7-B3E6-432E-B636-333449892EA6}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "kklib-test", "kklib-test.vcxproj", "{FEF7858F-750E-4C21-A04D-22707CC66878}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "kklib-test-interactive", "kklib-test-interactive.vcxproj", "{FEF78590-750E-4C21-A04D-22707CC66878}" +EndProject +Project("{8BC9CEB8-8B4A-11D0-8D11-00A0C91BC942}") = "kklib-test-effbayes", "kklib-test-effbayes.vcxproj", "{FEF78591-750E-4C21-A04D-22707CC66878}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|x64 = Debug|x64 + Debug|x86 = Debug|x86 + Release|x64 = Release|x64 + Release|x86 = Release|x86 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Debug|x64.ActiveCfg = Debug|x64 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Debug|x64.Build.0 = Debug|x64 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Debug|x86.ActiveCfg = Debug|Win32 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Debug|x86.Build.0 = Debug|Win32 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Release|x64.ActiveCfg = Release|x64 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Release|x64.Build.0 = Release|x64 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Release|x86.ActiveCfg = Release|Win32 + {ABB5EAE7-B3E6-432E-B636-333449892EA6}.Release|x86.Build.0 = Release|Win32 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Debug|x64.ActiveCfg = Debug|x64 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Debug|x64.Build.0 = Debug|x64 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Debug|x86.ActiveCfg = Debug|Win32 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Debug|x86.Build.0 = Debug|Win32 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Release|x64.ActiveCfg = Release|x64 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Release|x64.Build.0 = Release|x64 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Release|x86.ActiveCfg = Release|Win32 + {FEF7858F-750E-4C21-A04D-22707CC66878}.Release|x86.Build.0 = Release|Win32 + {FEF78590-750E-4C21-A04D-22707CC66878}.Debug|x64.ActiveCfg = Debug|x64 + {FEF78590-750E-4C21-A04D-22707CC66878}.Debug|x64.Build.0 = Debug|x64 + {FEF78590-750E-4C21-A04D-22707CC66878}.Debug|x86.ActiveCfg = Debug|Win32 + {FEF78590-750E-4C21-A04D-22707CC66878}.Debug|x86.Build.0 = Debug|Win32 + {FEF78590-750E-4C21-A04D-22707CC66878}.Release|x64.ActiveCfg = Release|x64 + {FEF78590-750E-4C21-A04D-22707CC66878}.Release|x64.Build.0 = Release|x64 + {FEF78590-750E-4C21-A04D-22707CC66878}.Release|x86.ActiveCfg = Release|Win32 + {FEF78590-750E-4C21-A04D-22707CC66878}.Release|x86.Build.0 = Release|Win32 + {FEF78591-750E-4C21-A04D-22707CC66878}.Debug|x64.ActiveCfg = Debug|x64 + {FEF78591-750E-4C21-A04D-22707CC66878}.Debug|x86.ActiveCfg = Debug|Win32 + {FEF78591-750E-4C21-A04D-22707CC66878}.Debug|x86.Build.0 = Debug|Win32 + {FEF78591-750E-4C21-A04D-22707CC66878}.Release|x64.ActiveCfg = Release|x64 + {FEF78591-750E-4C21-A04D-22707CC66878}.Release|x86.ActiveCfg = Release|Win32 + {FEF78591-750E-4C21-A04D-22707CC66878}.Release|x86.Build.0 = Release|Win32 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection + GlobalSection(ExtensibilityGlobals) = postSolution + SolutionGuid = {4297F93D-486A-4243-995F-7D32F59AE82A} + EndGlobalSection +EndGlobal diff --git a/kklib/ide/vs2022/kklib.vcxproj b/kklib/ide/vs2022/kklib.vcxproj new file mode 100644 index 000000000..ae248b443 --- /dev/null +++ b/kklib/ide/vs2022/kklib.vcxproj @@ -0,0 +1,250 @@ + + + + + Debug + Win32 + + + Release + Win32 + + + Debug + x64 + + + Release + x64 + + + + 15.0 + {ABB5EAE7-B3E6-432E-B636-333449892EA6} + kklib + 10.0 + kklib + + + + StaticLibrary + true + v143 + + + StaticLibrary + false + v143 + true + + + StaticLibrary + true + v143 + + + StaticLibrary + false + v143 + true + + + + + + + + + + + + + + + + + + + + + $(SolutionDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(SolutionDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + .lib + kklib + + + $(SolutionDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(SolutionDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + .lib + kklib + + + $(SolutionDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(SolutionDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + .lib + kklib + + + $(SolutionDir)..\..\out\msvc-$(Platform)\$(Configuration)\ + $(SolutionDir)..\..\out\msvc-$(Platform)\$(ProjectName)\$(Configuration)\ + .lib + kklib + + + + Level4 + Disabled + true + true + ../../include;../../mimalloc/include + KK_DEBUG=1;KK_STAT=2;KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;DEBUG=3;%(PreprocessorDefinitions); + CompileAsCpp + false + stdcpp17 + ProgramDatabase + + + + + + + + + + + Level4 + Disabled + true + true + ../../include;../../mimalloc/include + KK_DEBUG=1;KK_STAT=2;KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;DEBUG=3;%(PreprocessorDefinitions); + true + stdcpp17 + EditAndContinue + CompileAsCpp + Strict + + + + + + + + + + + + + + + + + + + Level4 + MaxSpeed + true + true + ../../include;../../mimalloc/include + KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;%(PreprocessorDefinitions);NDEBUG + AssemblyAndSourceCode + $(IntDir) + true + false + Default + CompileAsCpp + true + stdcpp17 + + + true + true + + + + + + + + + + + Level4 + MaxSpeed + true + true + ../../include;../../mimalloc/include + KK_STATIC_LIB=1;KK_MIMALLOC=1;_CONSOLE=1;%(PreprocessorDefinitions);NDEBUG + AssemblyAndSourceCode + $(IntDir) + true + false + Default + true + stdcpp17 + CompileAsCpp + Strict + + + true + true + + + + + + + + + + + + + + + + + + Level3 + Level3 + + + + + + + + + + AssemblyAndSourceCode + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/kklib/ide/vs2022/kklib.vcxproj.filters b/kklib/ide/vs2022/kklib.vcxproj.filters new file mode 100644 index 000000000..a7df4aa39 --- /dev/null +++ b/kklib/ide/vs2022/kklib.vcxproj.filters @@ -0,0 +1,108 @@ + + + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + Header Files + + + + + {2b556b10-f559-4b2d-896e-142652adbf0c} + + + {852a14ae-6dde-4e95-8077-ca705e97e5af} + + + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + Source Files + + + + + + \ No newline at end of file diff --git a/kklib/include/kklib.h b/kklib/include/kklib.h index 0dc53d5d9..19cb40bb0 100644 --- a/kklib/include/kklib.h +++ b/kklib/include/kklib.h @@ -1,11 +1,6 @@ #pragma once #ifndef KKLIB_H #define KKLIB_H - -#define KKLIB_BUILD 89 // modify on changes to trigger recompilation -#define KK_MULTI_THREADED 1 // set to 0 to be used single threaded only -// #define KK_DEBUG_FULL 1 // set to enable full internal debug checks - /*--------------------------------------------------------------------------- Copyright 2020-2022, Microsoft Research, Daan Leijen. @@ -13,6 +8,11 @@ terms of the Apache License, Version 2.0. A copy of the License can be found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ + +#define KKLIB_BUILD 114 // modify on changes to trigger recompilation +// #define KK_DEBUG_FULL 1 // set to enable full internal debug checks + +// Includes #define WIN32_LEAN_AND_MEAN // reduce windows includes #define _POSIX_C_SOURCE 200809L // make posix definitions visible #define _DARWIN_C_SOURCE 200809L // make darwin definitions visible @@ -45,7 +45,6 @@ #include "kklib/platform.h" // Platform abstractions and portability definitions #include "kklib/atomic.h" // Atomic operations -#include "kklib/process.h" // Process info (memory usage, run time etc.) /*-------------------------------------------------------------------------------------- @@ -94,44 +93,53 @@ static inline bool kk_tag_is_raw(kk_tag_t tag) { Headers --------------------------------------------------------------------------------------*/ - // The reference count is 0 for a unique reference (for a faster free test in drop). -// Reference counts larger than 0x8000000 (i.e. < 0) use atomic increment/decrement (for thread shared objects). +// Negative reference counts use atomic increment/decrement (for thread shared objects). // (Reference counts are always 32-bit (even on 64-bit) platforms but get "sticky" if -// they get too large and in such case we never free the object, see `refcount.c`) -typedef uint32_t kk_refcount_t; +// they overflow into the negative range and in such case we never free the object, see `refcount.c`) +typedef int32_t kk_refcount_t; // Are there (possibly) references from other threads? (includes static variables) static inline bool kk_refcount_is_thread_shared(kk_refcount_t rc) { - return ((int32_t)rc < 0); + return (rc < 0); } // Is the reference unique, or are there (possibly) references from other threads? (includes static variables) static inline bool kk_refcount_is_unique_or_thread_shared(kk_refcount_t rc) { - return ((int32_t)rc <= 0); + return (rc <= 0); } +// Increment a positive reference count. To avoid UB on overflow, use unsigned addition. +static inline kk_refcount_t kk_refcount_inc(kk_refcount_t rc) { + kk_assert_internal(rc >= 0); + return (kk_refcount_t)((uint32_t)rc + 1); +} + +// context path index +typedef int kk_cpath_t; +#define KK_CPATH_MAX (0xFF) // Every heap block starts with a 64-bit header with a reference count, tag, and scan fields count. // If the scan_fsize == 0xFF, the full scan count is in the first field as a boxed int (which includes the scan field itself). typedef struct kk_header_s { uint8_t scan_fsize; // number of fields that should be scanned when releasing (`scan_fsize <= 0xFF`, if 0xFF, the full scan size is the first field) - uint8_t _field_idx; // private: only used during stack-less freeing and marking (see `refcount.c`) + uint8_t _field_idx; // private: used for context paths and during stack-less freeing (see `refcount.c`) uint16_t tag; // constructor tag _Atomic(kk_refcount_t) refcount; // reference count (last to reduce code size constants in kk_header_init) } kk_header_t; #define KK_SCAN_FSIZE_MAX (0xFF) -#define KK_HEADER(scan_fsize,tag) { scan_fsize, 0, tag, ATOMIC_VAR_INIT(0) } // start with refcount of 0 -#define KK_HEADER_STATIC(scan_fsize,tag) { scan_fsize, 0, tag, ATOMIC_VAR_INIT(KK_U32(0x80000000)) } // start with a stuck refcount (RC_STUCK) +#define KK_HEADER(scan_fsize,fidx,tag) { scan_fsize, fidx, tag, KK_ATOMIC_VAR_INIT(0) } // start with unique refcount +#define KK_HEADER_STATIC(scan_fsize,tag) { scan_fsize, 0, tag, KK_ATOMIC_VAR_INIT(INT32_MIN) } // start with a stuck refcount (RC_STUCK) -static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_tag_t tag) { +static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_cpath_t cpath, kk_tag_t tag) { kk_assert_internal(scan_fsize >= 0 && scan_fsize <= KK_SCAN_FSIZE_MAX); + kk_assert_internal(cpath >= 0 && cpath <= KK_CPATH_MAX); #if (KK_ARCH_LITTLE_ENDIAN && !defined(__aarch64__)) - *((uint64_t*)h) = ((uint64_t)scan_fsize | (uint64_t)tag << 16); // explicit shifts leads to better codegen in general + *((uint64_t*)h) = ((uint64_t)scan_fsize | ((uint64_t)cpath << 8) | ((uint64_t)tag << 16)); // explicit shifts leads to better codegen in general #else - kk_header_t header = KK_HEADER((uint8_t)scan_fsize, (uint16_t)tag); + kk_header_t header = KK_HEADER((uint8_t)scan_fsize, (uint8_t)cpath, (uint16_t)tag); *h = header; #endif } @@ -142,30 +150,32 @@ static inline void kk_header_init(kk_header_t* h, kk_ssize_t scan_fsize, kk_tag_ --------------------------------------------------------------------------------------*/ // Polymorphic operations work on boxed values. (We use a struct for extra checks to prevent accidental conversion) -// The least significant bit is clear for `kk_block_t*` pointers, while it is set for values. +// The least-significant bit is clear for heap pointers (`kk_ptr_t == kk_block_t*`), while the bit is set for values. // See `box.h` for definitions. typedef struct kk_box_s { - uintptr_t box; + kk_intb_t box; } kk_box_t; // An integer is either a small int (as: 4*i + 1) or a `kk_bigint_t*` pointer. Isomorphic with boxed values. // See `integer.h` for definitions. typedef struct kk_integer_s { - uintptr_t ibox; + kk_intb_t ibox; } kk_integer_t; // A general datatype with constructors and singletons is either // an enumeration (with the lowest bit set as: 4*tag + 1) or a `kk_block_t*` pointer. // Isomorphic with boxed values. typedef struct kk_datatype_s { - uintptr_t dbox; + kk_intb_t dbox; } kk_datatype_t; +// Typedef to signify datatypes that have no singletons (and are always a pointer) +typedef kk_datatype_t kk_datatype_ptr_t; // boxed forward declarations -static inline kk_intf_t kk_intf_unbox(kk_box_t v); -static inline kk_box_t kk_intf_box(kk_intf_t u); - +static inline kk_intf_t kk_intf_unbox(kk_box_t b); +static inline kk_box_t kk_intf_box(kk_intf_t i); +static inline bool kk_box_is_any(kk_box_t b); /*-------------------------------------------------------------------------------------- Blocks @@ -242,11 +252,32 @@ static inline kk_decl_const bool kk_block_has_tag(const kk_block_t* b, kk_tag_t static inline kk_decl_pure kk_ssize_t kk_block_scan_fsize(const kk_block_t* b) { // number of scan fields const kk_ssize_t sfsize = b->header.scan_fsize; - if (kk_likely(sfsize != KK_SCAN_FSIZE_MAX)) return sfsize; + if kk_likely(sfsize != KK_SCAN_FSIZE_MAX) return sfsize; const kk_block_large_t* bl = (const kk_block_large_t*)b; return (kk_ssize_t)kk_intf_unbox(bl->large_scan_fsize); } +static inline void kk_block_set_invalid(kk_block_t* b) { +#ifdef KK_DEBUG_FULL + const kk_ssize_t scan_fsize = kk_block_scan_fsize(b); + const kk_ssize_t bsize = (sizeof(kk_box_t) * scan_fsize) + (b->header.scan_fsize == KK_SCAN_FSIZE_MAX ? sizeof(kk_block_large_t) : sizeof(kk_block_t)); + uint8_t* p = (uint8_t*)b; + for (kk_ssize_t i = 0; i < bsize; i++) { + p[i] = 0xDF; + } +#else + kk_unused(b); +#endif +} + +static inline kk_decl_pure bool kk_block_is_valid(kk_block_t* b) { + return (b != NULL && ((uintptr_t)b & 1) == 0 && *((uint64_t*)b) != KK_U64(0xDFDFDFDFDFDFDFDF) // already freed! + && (b->header.tag > KK_TAG_MAX || b->header.tag < 0xFF) + && (b->header._field_idx <= b->header.scan_fsize) + ); +} + + static inline kk_decl_pure kk_refcount_t kk_block_refcount(const kk_block_t* b) { return kk_atomic_load_relaxed(&b->header.refcount); } @@ -256,19 +287,25 @@ static inline void kk_block_refcount_set(kk_block_t* b, kk_refcount_t rc) { } static inline kk_decl_pure bool kk_block_is_unique(const kk_block_t* b) { - return (kk_likely(kk_block_refcount(b) == 0)); + return kk_likely(kk_block_refcount(b) == 0); } static inline kk_decl_pure bool kk_block_is_thread_shared(const kk_block_t* b) { - return (kk_unlikely(kk_refcount_is_thread_shared(kk_block_refcount(b)))); + return kk_unlikely(kk_refcount_is_thread_shared(kk_block_refcount(b))); } +// Used to generically inspect the scannable fields of an object as used +// to recursively free data, or mark as shared. This must overlay with +// any heap block and if pointer compression is used we need to use packed +// structures to avoid any potential padding in a struct (at least up to +// the first `scan_fsize` fields) typedef struct kk_block_fields_s { kk_block_t _block; kk_box_t fields[1]; } kk_block_fields_t; static inline kk_decl_pure kk_box_t kk_block_field(kk_block_t* b, kk_ssize_t index) { + kk_assert_internal(kk_block_is_valid(b)); kk_block_fields_t* bf = (kk_block_fields_t*)b; // must overlap with datatypes with scanned fields. return bf->fields[index]; } @@ -278,26 +315,18 @@ static inline void kk_block_field_set(kk_block_t* b, kk_ssize_t index, kk_box_t bf->fields[index] = v; } -#if (KK_INTPTR_SIZE==8) -#define KK_BLOCK_INVALID KK_UP(0xDFDFDFDFDFDFDFDF) -#else -#define KK_BLOCK_INVALID KK_UP(0xDFDFDFDF) -#endif +static inline kk_decl_pure kk_box_t* kk_block_field_address(kk_block_t* b, kk_ssize_t index) { + kk_block_fields_t* bf = (kk_block_fields_t*)b; // must overlap with datatypes with scanned fields. + return &bf->fields[index]; +} -static inline void kk_block_set_invalid(kk_block_t* b) { -#ifdef KK_DEBUG_FULL - const kk_ssize_t scan_fsize = kk_block_scan_fsize(b); - const kk_box_t inv = { KK_BLOCK_INVALID }; - for (kk_ssize_t i = -1; i < scan_fsize; i++) { - kk_block_field_set(b, i, inv); - } -#else - kk_unused(b); -#endif -} +static inline kk_decl_pure uint8_t kk_block_field_idx(const kk_block_t* b) { + return b->header._field_idx; +} -static inline kk_decl_pure bool kk_block_is_valid(kk_block_t* b) { - return (b != NULL && ((uintptr_t)b&1)==0 && kk_block_field(b, 0).box != KK_BLOCK_INVALID); // already freed! +static inline void kk_block_field_idx_set(kk_block_t* b, uint8_t idx ) { + kk_assert_internal(idx <= b->header.scan_fsize); // allow +1 for trmc context paths + b->header._field_idx = idx; } @@ -307,26 +336,34 @@ static inline kk_decl_pure bool kk_block_is_valid(kk_block_t* b) { be (usually) accessed efficiently through a register. --------------------------------------------------------------------------------------*/ #ifdef KK_MIMALLOC -#if !defined(MI_MAX_ALIGN_SIZE) -# define MI_MAX_ALIGN_SIZE KK_INTPTR_SIZE -#endif -#ifdef KK_MIMALLOC_INLINE -#include "../mimalloc/include/mimalloc-inline.h" -#else -#include "../mimalloc/include/mimalloc.h" -#endif -typedef mi_heap_t* kk_heap_t; + #if !defined(MI_MAX_ALIGN_SIZE) + #if (KK_MIMALLOC > 1) + #define MI_MAX_ALIGN_SIZE KK_MIMALLOC + #else + #define MI_MAX_ALIGN_SIZE KK_INTPTR_SIZE + #endif + #endif + #if !defined(MI_DEBUG) && defined(KK_DEBUG_FULL) + #define MI_DEBUG 3 + #endif + #ifdef KK_MIMALLOC_INLINE + #include "../mimalloc/include/mimalloc-inline.h" + #else + #include "../mimalloc/include/mimalloc.h" + #endif + typedef mi_heap_t* kk_heap_t; #else -typedef void* kk_heap_t; + typedef void* kk_heap_t; #endif // A function has as its first field a pointer to a C function that takes the // `kk_function_t` itself as a first argument. The following fields are the free variables. -typedef struct kk_function_s { +struct kk_function_s { kk_block_t _block; - kk_box_t fun; + kk_box_t fun; // kk_kkfun_ptr_t // followed by free variables -} *kk_function_t; +}; +typedef kk_datatype_ptr_t kk_function_t; // A vector is an array of boxed values, or an empty singleton typedef kk_datatype_t kk_vector_t; @@ -341,15 +378,16 @@ typedef int64_t kk_secs_t; typedef int64_t kk_asecs_t; typedef struct kk_duration_s { kk_secs_t seconds; - kk_asecs_t attoseconds; // always >= 0 -} kk_duration_t; + kk_asecs_t attoseconds; // always >= 0, use `kk_duration_norm` to normalize +} kk_duration_t; // Box any is used when yielding -typedef struct kk_box_any_s { +struct kk_box_any_s { kk_block_t _block; kk_integer_t _unused; -} *kk_box_any_t; +}; +typedef kk_datatype_t kk_box_any_t; // Workers run in a task_group typedef struct kk_task_group_s kk_task_group_t; @@ -364,54 +402,48 @@ typedef enum kk_yield_kind_e { } kk_yield_kind_t; typedef struct kk_yield_s { - int32_t marker; // marker of the handler to yield to + int32_t marker; // marker of the handler to yield to kk_function_t clause; // the operation clause to execute when the handler is found - kk_ssize_t conts_count; // number of continuations in `conts` + kk_intf_t conts_count; // number of continuations in `conts` kk_function_t conts[KK_YIELD_CONT_MAX]; // fixed array of continuations. The final continuation `k` is // composed as `fN â—‹ ... â—‹ f2 â—‹ f1` if `conts = { f1, f2, ..., fN }` // if the array becomes full, a fresh array is allocated and the first // entry points to its composition. } kk_yield_t; - -extern kk_ptr_t kk_evv_empty_singleton; - // The thread local context. // The fields `yielding`, `heap` and `evv` should come first for efficiency typedef struct kk_context_s { - int8_t yielding; // are we yielding to a handler? 0:no, 1:yielding, 2:yielding_final (e.g. exception) // put first for efficiency - kk_heap_t heap; // the (thread-local) heap to allocate in; todo: put in a register? - kk_ptr_t evv; // the current evidence vector for effect handling: vector for size 0 and N>1, direct evidence for one element vector - kk_yield_t yield; // inlined yield structure (for efficiency) - int32_t marker_unique; // unique marker generation - kk_block_t* delayed_free; // list of blocks that still need to be freed - kk_integer_t unique; // thread local unique number generation - size_t thread_id; // unique thread id - kk_box_any_t kk_box_any; // used when yielding as a value of any type - kk_function_t log; // logging function - kk_function_t out; // std output - kk_task_group_t* task_group; // task group for managing threads. NULL for the main thread. + int8_t yielding; // are we yielding to a handler? 0:no, 1:yielding, 2:yielding_final (e.g. exception) // put first for efficiency + const kk_heap_t heap; // the (thread-local) heap to allocate in; todo: put in a register? + const kk_addr_t heap_mid; // mid point of the reserved heap address space (or 0 if the heap is not compressed) + const void* heap_start; // start of the heap space (or NULL if the heap is not compressed) + kk_datatype_ptr_t evv; // the current evidence vector for effect handling: vector for size 0 and N>1, direct evidence for one element vector + kk_yield_t yield; // inlined yield structure (for efficiency) + int32_t marker_unique; // unique marker generation + kk_block_t* delayed_free; // list of blocks that still need to be freed + kk_integer_t unique; // thread local unique number generation + size_t thread_id; // unique thread id + kk_box_any_t kk_box_any; // used when yielding as a value of any type + kk_function_t log; // logging function + kk_function_t out; // std output + kk_task_group_t* task_group; // task group for managing threads. NULL for the main thread. - struct kk_random_ctx_s* srandom_ctx; // strong random using chacha20, initialized on demand - kk_ssize_t argc; // command line argument count - const char** argv; // command line arguments - kk_timer_t process_start; // time at start of the process - int64_t timer_freq; // high precision timer frequency - kk_duration_t timer_prev; // last requested timer time - kk_duration_t timer_delta; // applied timer delta (to ensure monotonicity) - int64_t time_freq; // unix time frequency - kk_duration_t time_unix_prev; // last requested unix time + struct kk_random_ctx_s* srandom_ctx;// strong random using chacha20, initialized on demand + kk_ssize_t argc; // command line argument count + const char** argv; // command line arguments + kk_duration_t process_start; // time at start of the process + int64_t timer_freq; // high precision timer frequency + kk_duration_t timer_prev; // last requested timer time + kk_duration_t timer_delta; // applied timer delta (to ensure monotonicity) + int64_t time_freq; // unix time frequency + kk_duration_t time_unix_prev; // last requested unix time } kk_context_t; // Get the current (thread local) runtime context (should always equal the `_ctx` parameter) kk_decl_export kk_context_t* kk_get_context(void); kk_decl_export void kk_free_context(void); -kk_decl_export kk_context_t* kk_main_start(int argc, char** argv); -kk_decl_export void kk_main_end(kk_context_t* ctx); - -kk_decl_export void kk_debugger_break(kk_context_t* ctx); - // The current context is passed as a _ctx parameter in the generated code #define kk_context() _ctx @@ -432,15 +464,22 @@ static inline kk_decl_pure bool kk_yielding_final(const kk_context_t* ctx) { // Get a thread local marker unique number >= 1. static inline int32_t kk_marker_unique(kk_context_t* ctx) { - int32_t m = ++ctx->marker_unique; // must return a marker >= 1 so increment first; - if (m == INT32_MAX) ctx->marker_unique = 1; // controlled reset + int32_t m = ++ctx->marker_unique; // must return a marker >= 1 so increment first; + if (m == INT32_MAX) { ctx->marker_unique = 1; } // controlled reset return m; } +kk_decl_export kk_context_t* kk_main_start(int argc, char** argv); +kk_decl_export void kk_main_end(kk_context_t* ctx); + +kk_decl_export void kk_debugger_break(kk_context_t* ctx); +kk_decl_export void kk_fatal_error(int err, const char* msg, ...); +kk_decl_export void kk_warning_message(const char* msg, ...); +kk_decl_export void kk_info_message(const char* msg, ...); +kk_decl_export void kk_unsupported_external(const char* msg); + +kk_decl_export kk_datatype_ptr_t kk_evv_empty_singleton(kk_context_t* ctx); -kk_decl_export void kk_block_mark_shared( kk_block_t* b, kk_context_t* ctx ); -kk_decl_export void kk_box_mark_shared( kk_box_t b, kk_context_t* ctx ); -kk_decl_export void kk_box_mark_shared_recx(kk_box_t b, kk_context_t* ctx); /*-------------------------------------------------------------------------------------- Allocation @@ -480,6 +519,9 @@ static inline void kk_free(const void* p, kk_context_t* ctx) { static inline void kk_free_local(const void* p, kk_context_t* ctx) { kk_free(p,ctx); } + +#define kk_malloc_usable_size(p) mi_usable_size(p) + #else static inline void* kk_malloc(kk_ssize_t sz, kk_context_t* ctx) { kk_unused(ctx); @@ -508,31 +550,56 @@ static inline void kk_free(const void* p, kk_context_t* ctx) { static inline void kk_free_local(const void* p, kk_context_t* ctx) { kk_free(p,ctx); } + +#if defined(__linux__) || defined(__GLIBC__) +#include +#define kk_malloc_usable_size(p) malloc_usable_size(p) +#elif defined(__APPLE__) +#include +#define kk_malloc_usable_size(p) malloc_size(p) +#elif defined(_MSC_VER) +#include +#define kk_malloc_usable_size(p) _msize(p) +#endif + #endif +#if defined(kk_malloc_usable_size) +#define KK_HAS_MALLOC_COPY +static inline void* kk_malloc_copy(const void* p, kk_context_t* ctx) { + const size_t size = kk_malloc_usable_size((void*)p); + void* q = kk_malloc(kk_to_ssize_t(size), ctx); + memcpy(q,p,size); + return q; +} +#endif -static inline void kk_block_init(kk_block_t* b, kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag) { +static inline void kk_block_init(kk_block_t* b, kk_ssize_t size, kk_ssize_t scan_fsize, kk_cpath_t cpath, kk_tag_t tag) { kk_unused(size); kk_assert_internal(scan_fsize >= 0 && scan_fsize < KK_SCAN_FSIZE_MAX); - kk_header_init(&b->header, scan_fsize, tag); + kk_assert_internal(cpath >= 0 && cpath <= KK_CPATH_MAX); + kk_header_init(&b->header, scan_fsize, cpath, tag); } -static inline void kk_block_large_init(kk_block_large_t* b, kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag) { +static inline void kk_block_large_init(kk_block_large_t* b, kk_ssize_t size, kk_ssize_t scan_fsize, kk_cpath_t cpath, kk_tag_t tag) { kk_unused(size); // to optimize for "small" vectors with less than 255 scanable elements, we still set the small scan_fsize // for those in the header. This is still duplicated in the large scan_fsize field as it is used for the vector length for example. + kk_assert_internal(cpath >= 0 && cpath <= KK_CPATH_MAX); uint8_t bscan_fsize = (scan_fsize >= KK_SCAN_FSIZE_MAX ? KK_SCAN_FSIZE_MAX : (uint8_t)scan_fsize); - kk_header_init(&b->_block.header, bscan_fsize, tag); + kk_header_init(&b->_block.header, bscan_fsize, cpath, tag); kk_assert_internal(scan_fsize > 0); - b->large_scan_fsize = kk_intf_box(scan_fsize); + kk_assert_internal(scan_fsize <= KK_INTF_MAX); + b->large_scan_fsize = kk_intf_box((kk_intf_t)scan_fsize); } typedef kk_block_t* kk_reuse_t; #define kk_reuse_null ((kk_reuse_t)NULL) -static inline kk_block_t* kk_block_alloc_at(kk_reuse_t at, kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag, kk_context_t* ctx) { +static inline kk_block_t* kk_block_alloc_at(kk_reuse_t at, kk_ssize_t size, kk_ssize_t scan_fsize, kk_cpath_t cpath, kk_tag_t tag, kk_context_t* ctx) { kk_assert_internal(scan_fsize >= 0 && scan_fsize < KK_SCAN_FSIZE_MAX); + kk_assert_internal(cpath >= 0 && cpath <= KK_CPATH_MAX); kk_block_t* b; if (at==kk_reuse_null) { b = (kk_block_t*)kk_malloc_small(size, ctx); @@ -541,27 +608,27 @@ static inline kk_block_t* kk_block_alloc_at(kk_reuse_t at, kk_ssize_t size, kk_s kk_assert_internal(kk_block_is_unique(at)); // TODO: check usable size of `at` b = at; } - kk_block_init(b, size, scan_fsize, tag); + kk_block_init(b, size, scan_fsize, cpath, tag); return b; } static inline kk_block_t* kk_block_alloc(kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag, kk_context_t* ctx) { kk_assert_internal(scan_fsize >= 0 && scan_fsize < KK_SCAN_FSIZE_MAX); kk_block_t* b = (kk_block_t*)kk_malloc_small(size, ctx); - kk_block_init(b, size, scan_fsize, tag); + kk_block_init(b, size, scan_fsize, 0, tag); return b; } static inline kk_block_t* kk_block_alloc_any(kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag, kk_context_t* ctx) { kk_assert_internal(scan_fsize >= 0 && scan_fsize < KK_SCAN_FSIZE_MAX); kk_block_t* b = (kk_block_t*)kk_malloc(size, ctx); - kk_block_init(b, size, scan_fsize, tag); + kk_block_init(b, size, scan_fsize, 0, tag); return b; } static inline kk_block_large_t* kk_block_large_alloc(kk_ssize_t size, kk_ssize_t scan_fsize, kk_tag_t tag, kk_context_t* ctx) { kk_block_large_t* b = (kk_block_large_t*)kk_malloc(size, ctx); - kk_block_large_init(b, size, scan_fsize, tag); + kk_block_large_init(b, size, scan_fsize, 0, tag); return b; } @@ -581,8 +648,8 @@ static inline void kk_block_free(kk_block_t* b, kk_context_t* ctx) { kk_free(b, ctx); } -#define kk_block_alloc_as(struct_tp,scan_fsize,tag,ctx) ((struct_tp*)kk_block_alloc_at(kk_reuse_null, sizeof(struct_tp),scan_fsize,tag,ctx)) -#define kk_block_alloc_at_as(struct_tp,at,scan_fsize,tag,ctx) ((struct_tp*)kk_block_alloc_at(at, sizeof(struct_tp),scan_fsize,tag,ctx)) +#define kk_block_alloc_as(struct_tp,scan_fsize,tag,ctx) ((struct_tp*)kk_block_alloc( sizeof(struct_tp),scan_fsize,tag,ctx)) +#define kk_block_alloc_at_as(struct_tp,at,scan_fsize,cpath,tag,ctx) ((struct_tp*)kk_block_alloc_at(at, sizeof(struct_tp),scan_fsize,cpath,tag,ctx)) #define kk_block_as(tp,b) ((tp)((void*)(b))) #define kk_block_assert(tp,b,tag) ((tp)kk_block_assertx(b,tag)) @@ -609,11 +676,11 @@ kk_decl_export kk_reuse_t kk_block_check_drop_reuse(kk_block_t* b, kk_refcount_ static inline kk_block_t* kk_block_dup(kk_block_t* b) { kk_assert_internal(kk_block_is_valid(b)); const kk_refcount_t rc = kk_block_refcount(b); - if (kk_unlikely(kk_refcount_is_thread_shared(rc))) { // (signed)rc < 0 - return kk_block_check_dup(b, rc); // thread-shared or sticky (overflow) ? + if kk_unlikely(kk_refcount_is_thread_shared(rc)) { // (signed)rc < 0 + return kk_block_check_dup(b, rc); // thread-shared or sticky (overflow) ? } else { - kk_block_refcount_set(b, rc+1); + kk_block_refcount_set(b, kk_refcount_inc(rc)); return b; } } @@ -637,7 +704,7 @@ static inline void kk_block_drop(kk_block_t* b, kk_context_t* ctx) { static inline void kk_block_decref(kk_block_t* b, kk_context_t* ctx) { kk_assert_internal(kk_block_is_valid(b)); const kk_refcount_t rc = b->header.refcount; - if (kk_unlikely(kk_refcount_is_unique_or_thread_shared(rc))) { // (signed)rc <= 0 + if kk_unlikely(kk_refcount_is_unique_or_thread_shared(rc)) { // (signed)rc <= 0 kk_block_check_decref(b, rc, ctx); // thread-shared, sticky (overflowed), or can be freed? } else { @@ -672,7 +739,7 @@ static inline void kk_block_dropi(kk_block_t* b, kk_context_t* ctx) { } kk_block_free(b,ctx); } - else if (kk_unlikely(kk_refcount_is_thread_shared(rc))) { // (signed)rc < 0 + else if kk_unlikely(kk_refcount_is_thread_shared(rc)) { // (signed)rc < 0 kk_block_check_drop(b, rc, ctx); // thread-share or sticky (overflowed) ? } else { @@ -708,7 +775,7 @@ static inline void kk_block_dropn(kk_block_t* b, kk_ssize_t scan_fsize, kk_conte } kk_block_free(b,ctx); } - else if (kk_unlikely(kk_refcount_is_thread_shared(rc))) { // (signed)rc < 0 + else if kk_unlikely(kk_refcount_is_thread_shared(rc)) { // (signed)rc < 0 kk_block_check_drop(b, rc, ctx); // thread-shared, sticky (overflowed)? } else { @@ -729,7 +796,7 @@ static inline kk_reuse_t kk_block_dropn_reuse(kk_block_t* b, kk_ssize_t scan_fsi } return b; } - else if (kk_unlikely(kk_refcount_is_thread_shared(rc))) { // (signed)rc < 0 + else if kk_unlikely(kk_refcount_is_thread_shared(rc)) { // (signed)rc < 0 kk_block_check_drop(b, rc, ctx); // thread-shared or sticky (overflowed)? return kk_reuse_null; } @@ -761,55 +828,183 @@ static inline void kk_reuse_drop(kk_reuse_t r, kk_context_t* ctx) { /*-------------------------------------------------------------------------------------- - Datatype and Constructor macros - We use: - - basetype For a pointer to the base type of a heap allocated constructor. - Datatypes without singletons are always a basetype. - - datatype For a regular datatypes that can have singletons. + Thread-shared marking (see `refcount.c`) +--------------------------------------------------------------------------------------*/ + +kk_decl_export void kk_block_mark_shared(kk_block_t* b, kk_context_t* ctx); +kk_decl_export void kk_box_mark_shared(kk_box_t b, kk_context_t* ctx); +kk_decl_export void kk_box_mark_shared_recx(kk_box_t b, kk_context_t* ctx); + + +/*-------------------------------------------------------------------------------------- + Base type and Constructor macros + - base_type For a pointer to the base type of a heap allocated constructor. - constructor For a pointer to a heap allocated constructor (whose first field is `_base` and points to the base type as a `basetype` --------------------------------------------------------------------------------------*/ -//#define kk_basetype_tag(v) (kk_block_tag(&((v)->_block))) -#define kk_basetype_has_tag(v,t) (kk_block_has_tag(&((v)->_block),t)) -#define kk_basetype_is_unique(v) (kk_block_is_unique(&((v)->_block))) -#define kk_basetype_as(tp,v) (kk_block_as(tp,&((v)->_block))) -#define kk_basetype_free(v,ctx) (kk_block_free(&((v)->_block),ctx)) -#define kk_basetype_decref(v,ctx) (kk_block_decref(&((v)->_block),ctx)) -#define kk_basetype_dup_as(tp,v) ((tp)kk_block_dup(&((v)->_block))) -#define kk_basetype_drop(v,ctx) (kk_block_dropi(&((v)->_block),ctx)) -#define kk_basetype_dropn_reuse(v,n,ctx) (kk_block_dropn_reuse(&((v)->_block),n,ctx)) -#define kk_basetype_dropn(v,n,ctx) (kk_block_dropn(&((v)->_block),n,ctx)) -#define kk_basetype_reuse(v) (&((v)->_block)) - -#define kk_basetype_as_assert(tp,v,tag) (kk_block_assert(tp,&((v)->_block),tag)) -#define kk_basetype_drop_assert(v,tag,ctx) (kk_block_drop_assert(&((v)->_block),tag,ctx)) -#define kk_basetype_dup_assert(tp,v,tag) ((tp)kk_block_dup_assert(&((v)->_block),tag)) - -#define kk_constructor_tag(v) (kk_basetype_tag(&((v)->_base))) -#define kk_constructor_is_unique(v) (kk_basetype_is_unique(&((v)->_base))) -#define kk_constructor_free(v,ctx) (kk_basetype_free(&((v)->_base),ctx)) -#define kk_constructor_dup_as(tp,v) (kk_basetype_dup_as(tp, &((v)->_base))) -#define kk_constructor_drop(v,ctx) (kk_basetype_drop(&((v)->_base),ctx)) -#define kk_constructor_dropn_reuse(v,n,ctx) (kk_basetype_dropn_reuse(&((v)->_base),n,ctx)) - -#define kk_value_dup(v) (v) -#define kk_value_drop(v,ctx) (void) -#define kk_value_drop_reuse(v,ctx) (kk_reuse_null) +#define kk_base_type_has_tag(v,t) (kk_block_has_tag(&((v)->_block),t)) +#define kk_base_type_is_unique(v) (kk_block_is_unique(&((v)->_block))) +#define kk_base_type_as(tp,v) (kk_block_as(tp,&((v)->_block))) +#define kk_base_type_free(v,ctx) (kk_block_free(&((v)->_block),ctx)) +#define kk_base_type_decref(v,ctx) (kk_block_decref(&((v)->_block),ctx)) +#define kk_base_type_dup_as(tp,v) ((tp)kk_block_dup(&((v)->_block))) +#define kk_base_type_drop(v,ctx) (kk_block_dropi(&((v)->_block),ctx)) +#define kk_base_type_dropn_reuse(v,n,ctx) (kk_block_dropn_reuse(&((v)->_block),n,ctx)) +#define kk_base_type_dropn(v,n,ctx) (kk_block_dropn(&((v)->_block),n,ctx)) +#define kk_base_type_reuse(v) (&((v)->_block)) +#define kk_base_type_field_idx_set(v,x) (kk_block_field_idx_set(&((v)->_block),x)) + +#define kk_base_type_as_assert(tp,v,tag) (kk_block_assert(tp,&((v)->_block),tag)) +#define kk_base_type_drop_assert(v,tag,ctx) (kk_block_drop_assert(&((v)->_block),tag,ctx)) +#define kk_base_type_dup_assert(tp,v,tag) ((tp)kk_block_dup_assert(&((v)->_block),tag)) + +#define kk_base_type_unbox_as_assert(tp,b,tag,ctx) (kk_block_as(tp,kk_block_unbox(b,tag,ctx))) +#define kk_base_type_unbox_as(tp,b,ctx) ((tp)kk_base_type_as(tp,kk_ptr_unbox(b,ctx),ctx)) +#define kk_base_type_box(b,ctx) (kk_block_box(&(b)->_block,ctx)) + +#define kk_constructor_is_unique(v) (kk_base_type_is_unique(&((v)->_base))) +#define kk_constructor_free(v,ctx) (kk_base_type_free(&((v)->_base),ctx)) +#define kk_constructor_dup_as(tp,v) (kk_base_type_dup_as(tp, &((v)->_base))) +#define kk_constructor_drop(v,ctx) (kk_base_type_drop(&((v)->_base),ctx)) +#define kk_constructor_dropn_reuse(v,n,ctx) (kk_base_type_dropn_reuse(&((v)->_base),n,ctx)) +#define kk_constructor_field_idx_set(v,x) (kk_base_type_field_idx_set(&((v)->_base),x)) +#define kk_constructor_unbox_as(tp,b,tag,ctx) (kk_base_type_unbox_as_assert(tp,b,tag,ctx)) +#define kk_constructor_box(b,ctx) (kk_base_type_box(&(b)->_base),ctx) + + +/*---------------------------------------------------------------------- + Low-level encoding of small integers (`kk_intf_t`) and pointers + into a boxed integer `kk_intb_t`. +----------------------------------------------------------------------*/ +// We generally tag boxed values; the least-significant bit is clear for heap pointers (`kk_ptr_t == kk_block_t*`), +// while the bit is set for values. +#define KK_TAG_BITS (1) +#define KK_TAG_MASK ((1<= 3) + // shift by pointer alignment if we have at most 32-bit boxed ints + // note: unfortunately, bigint pointers must still have the lowest 2 bits as zero for + // fast ovf arithmetic. So we are conservative here. If we always use SOFA or TAGOVF + // in the compressed case, we could shift by one more bit and double the heap space. + #define KK_BOX_PTR_SHIFT (KK_INTPTR_SHIFT - 2) + #else + // don't bother with shifting if we have more than 32 bits available + #define KK_BOX_PTR_SHIFT (0) + #endif +#endif + +// Without compression, pointer encode/decode is an identity operation. +static inline kk_intb_t kk_ptr_encode(kk_ptr_t p, kk_context_t* ctx) { + kk_assert_internal(((intptr_t)p & KK_TAG_MASK) == 0); + kk_addr_t a; +#if KK_COMPRESS + #if KK_CHERI + a = (kk_addr_t)__builtin_cheri_address_get(p); + #else + a = (kk_addr_t)p; + #endif + #if (KK_INTB_SIZE==4) + // compress to 32-bit offsets, ctx->heap_mid contains the mid-point in the heap so we can do signed extension + a = a - ctx->heap_mid; + #else + // for 64- or 128-bit we use the address as is (and for 128 bit we assume we locate our heap in the lower 2^63-1 address space) + kk_unused(ctx); + #endif + #if KK_BOX_PTR_SHIFT > 0 + kk_assert_internal((a & ((1 << KK_BOX_PTR_SHIFT) - 1)) == 0); + a = kk_sara(a, KK_BOX_PTR_SHIFT); + #endif +#else // no compression: |kk_intptr_t| == |kk_addr_t| == |kk_intb_t| + kk_unused(ctx); + a = (kk_addr_t)p; +#endif + kk_assert_internal(a >= KK_INTB_MIN && a <= KK_INTB_MAX); + kk_assert_internal((a & KK_TAG_MASK) == 0); + return ((kk_intb_t)a | KK_TAG_PTR); +} + +static inline kk_ptr_t kk_ptr_decode(kk_intb_t b, kk_context_t* ctx) { + kk_assert_internal(kk_is_ptr(b)); + kk_addr_t a = b; // may sign-extend +#if (KK_TAG_PTR != 0) + a = (a & ~KK_TAG_MASK); +#endif +#if KK_COMPRESS + #if (KK_BOX_PTR_SHIFT > 0) + a = kk_shla(a, KK_BOX_PTR_SHIFT); + #endif + #if (KK_INTB_SIZE == 4) + a = a + ctx->heap_mid; + #else + kk_unused(ctx); + #endif + #if KK_CHERI + return (kk_ptr_t)__builtin_cheri_address_set(ctx->heap_start, (vaddr_t)a); + #else + return (kk_ptr_t)a; + #endif +#else // no compression: |kk_intb_t| == |kk_addr_t| == |intptr_t| + kk_unused(ctx); + return (kk_ptr_t)a; +#endif +} + +// Integer value encoding/decoding. May use smaller integers (`kk_intf_t`) +// then boxed integers if `kk_intb_t` is larger than the natural register size. +#define KK_INTF_BOX_BITS(extra) (KK_INTF_BITS - (KK_TAG_BITS + (extra))) +#define KK_INTF_BOX_MAX(extra) (KK_INTF_MAX >> (KK_TAG_BITS + (extra))) +#define KK_INTF_BOX_MIN(extra) (-KK_INTF_BOX_MAX(extra) - 1) +#define KK_UINTF_BOX_MAX(extra) (KK_UINTF_MAX >>(KK_TAG_BITS + (extra))) + +static inline kk_intb_t kk_intf_encode(kk_intf_t i, int extra_shift) { + kk_assert_internal(extra_shift >= 0); + kk_intb_t b = i; // may sign-extend + kk_assert_internal(b >= KK_INTF_BOX_MIN(extra_shift) && i <= KK_INTF_BOX_MAX(extra_shift)); + return (kk_shlb(b,KK_TAG_BITS + extra_shift) | KK_TAG_VALUE); +} + +static inline kk_intf_t kk_intf_decode(kk_intb_t b, int extra_shift) { + kk_assert_internal(extra_shift >= 0); + kk_assert_internal(kk_is_value(b) || b == kk_get_context()->kk_box_any.dbox); + kk_intb_t i = kk_sarb( b, KK_TAG_BITS + extra_shift); + kk_assert_internal(i >= KK_INTF_MIN && i <= KK_INTF_MAX); + return (kk_intf_t)i; +} + /*---------------------------------------------------------------------- Datatypes + We use the `_ptr` suffix if it is guaranteed that the datatype + is a pointer and not a value (singleton). ----------------------------------------------------------------------*/ // create a singleton static inline kk_decl_const kk_datatype_t kk_datatype_from_tag(kk_tag_t t) { - kk_datatype_t d = { (((kk_uintf_t)t)<<2 | 1) }; + kk_datatype_t d = { kk_intf_encode((kk_intf_t)t,1) }; return d; } -static inline kk_decl_const kk_datatype_t kk_datatype_from_ptr(kk_ptr_t p) { - kk_datatype_t d = { (uintptr_t)p }; +// create a pointer into the heap +static inline kk_decl_const kk_datatype_t kk_datatype_from_ptr(kk_ptr_t p, kk_context_t* ctx) { + kk_datatype_t d = { kk_ptr_encode(p, ctx) }; return d; } @@ -818,135 +1013,196 @@ static inline kk_decl_const bool kk_datatype_eq(kk_datatype_t x, kk_datatype_t y } static inline kk_decl_const bool kk_datatype_is_ptr(kk_datatype_t d) { - return ((((kk_uintf_t)d.dbox)&1) == 0); + return kk_is_ptr(d.dbox); } static inline kk_decl_const bool kk_datatype_is_singleton(kk_datatype_t d) { - return ((((kk_uintf_t)d.dbox)&1) == 1); + return kk_is_value(d.dbox); } -static inline kk_decl_pure kk_tag_t kk_datatype_tag(kk_datatype_t d) { +static inline kk_decl_const kk_block_t* kk_datatype_as_ptr(kk_datatype_t d, kk_context_t* ctx) { + kk_assert_internal(kk_datatype_is_ptr(d)); + return kk_ptr_decode(d.dbox,ctx); +} + +static inline kk_decl_pure kk_tag_t kk_datatype_ptr_tag(kk_datatype_t d, kk_context_t* ctx) { + kk_assert_internal(kk_datatype_is_ptr(d)); + return kk_block_tag(kk_datatype_as_ptr(d, ctx)); +} + +static inline kk_decl_pure kk_tag_t kk_datatype_tag(kk_datatype_t d, kk_context_t* ctx) { if (kk_datatype_is_ptr(d)) { - return kk_block_tag((kk_ptr_t)d.dbox); + return kk_datatype_ptr_tag(d, ctx); } else { - return (kk_tag_t)(((kk_uintf_t)d.dbox) >> 2); + return (kk_tag_t)kk_intf_decode(d.dbox,1); } } -static inline kk_decl_pure bool kk_datatype_has_tag(kk_datatype_t d, kk_tag_t t) { +static inline kk_decl_pure bool kk_datatype_ptr_has_tag(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { + kk_assert_internal(kk_datatype_is_ptr(d)); + return (kk_block_tag(kk_datatype_as_ptr(d, ctx)) == t); +} + + +static inline kk_decl_pure bool kk_datatype_has_tag(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { if (kk_datatype_is_ptr(d)) { - return (kk_block_tag((kk_ptr_t)d.dbox) == t); + return kk_datatype_ptr_has_tag(d, t, ctx); } else { - return (d.dbox == kk_datatype_from_tag(t).dbox); // todo: optimize if sizeof(kk_uintf_t) < sizeof(uintptr_t) ? + return (d.dbox == kk_datatype_from_tag(t).dbox); } } -static inline kk_decl_pure bool kk_datatype_has_ptr_tag(kk_datatype_t d, kk_tag_t t) { - return (kk_datatype_is_ptr(d) && kk_block_tag((kk_ptr_t)d.dbox) == t); +static inline kk_decl_pure bool kk_datatype_has_ptr_tag(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { + return (kk_datatype_is_ptr(d) && kk_block_tag(kk_datatype_as_ptr(d,ctx)) == t); } static inline kk_decl_pure bool kk_datatype_has_singleton_tag(kk_datatype_t d, kk_tag_t t) { - return (d.dbox == kk_datatype_from_tag(t).dbox); // todo: optimize if sizeof(kk_uintf_t) < sizeof(uintptr_t) ? + return (d.dbox == kk_datatype_from_tag(t).dbox); } - -static inline kk_decl_const kk_block_t* kk_datatype_as_ptr(kk_datatype_t d) { +static inline bool kk_decl_pure kk_datatype_ptr_is_unique(kk_datatype_t d, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); - return (kk_ptr_t)d.dbox; + //return (kk_datatype_is_ptr(d) && kk_block_is_unique(kk_datatype_as_ptr(d))); + return kk_block_is_unique(kk_datatype_as_ptr(d,ctx)); } +static inline bool kk_decl_pure kk_datatype_is_unique(kk_datatype_t d, kk_context_t* ctx) { + return (kk_datatype_is_ptr(d) && kk_block_is_unique(kk_datatype_as_ptr(d,ctx))); +} -static inline bool kk_decl_pure kk_datatype_is_unique(kk_datatype_t d) { - kk_assert_internal(kk_datatype_is_ptr(d)); - //return (kk_datatype_is_ptr(d) && kk_block_is_unique(kk_datatype_as_ptr(d))); - return kk_block_is_unique(kk_datatype_as_ptr(d)); +static inline kk_datatype_t kk_datatype_ptr_dup(kk_datatype_t d, kk_context_t* ctx) { + kk_assert_internal(kk_datatype_is_ptr(d)); + kk_block_dup(kk_datatype_as_ptr(d, ctx)); + return d; } -static inline kk_datatype_t kk_datatype_dup(kk_datatype_t d) { - if (kk_datatype_is_ptr(d)) { kk_block_dup(kk_datatype_as_ptr(d)); } + +static inline kk_datatype_t kk_datatype_dup(kk_datatype_t d, kk_context_t* ctx) { + if (kk_datatype_is_ptr(d)) { + kk_datatype_ptr_dup(d,ctx); + } return d; } +static inline void kk_datatype_ptr_drop(kk_datatype_t d, kk_context_t* ctx) { + kk_assert_internal(kk_datatype_is_ptr(d)); + kk_block_drop(kk_datatype_as_ptr(d, ctx), ctx); +} + static inline void kk_datatype_drop(kk_datatype_t d, kk_context_t* ctx) { - if (kk_datatype_is_ptr(d)) { kk_block_drop(kk_datatype_as_ptr(d),ctx); } + if (kk_datatype_is_ptr(d)) { + kk_datatype_ptr_drop(d, ctx); + } } -static inline void kk_datatype_dropn(kk_datatype_t d, kk_ssize_t scan_fsize, kk_context_t* ctx) { +static inline void kk_datatype_ptr_dropn(kk_datatype_t d, kk_ssize_t scan_fsize, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); kk_assert_internal(scan_fsize > 0); - kk_block_dropn(kk_datatype_as_ptr(d), scan_fsize, ctx); + kk_block_dropn(kk_datatype_as_ptr(d,ctx), scan_fsize, ctx); +} + +static inline kk_datatype_t kk_datatype_ptr_dup_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { + kk_unused_internal(t); + kk_assert_internal(kk_datatype_ptr_has_tag(d, t, ctx)); + return kk_datatype_ptr_dup(d, ctx); } -static inline kk_datatype_t kk_datatype_dup_assert(kk_datatype_t d, kk_tag_t t) { +static inline kk_datatype_t kk_datatype_dup_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { kk_unused_internal(t); - kk_assert_internal(kk_datatype_has_tag(d, t)); - return kk_datatype_dup(d); + kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); + return kk_datatype_dup(d, ctx); +} + +static inline void kk_datatype_ptr_drop_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { + kk_unused(t); + kk_assert_internal(kk_datatype_ptr_has_tag(d, t, ctx) || kk_datatype_ptr_has_tag(d, KK_TAG_BOX_ANY, ctx)); + kk_datatype_ptr_drop(d, ctx); } static inline void kk_datatype_drop_assert(kk_datatype_t d, kk_tag_t t, kk_context_t* ctx) { kk_unused_internal(t); - kk_assert_internal(kk_datatype_has_tag(d, t)); + kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); kk_datatype_drop(d, ctx); } -static inline kk_reuse_t kk_datatype_dropn_reuse(kk_datatype_t d, kk_ssize_t scan_fsize, kk_context_t* ctx) { +static inline kk_reuse_t kk_datatype_ptr_dropn_reuse(kk_datatype_t d, kk_ssize_t scan_fsize, kk_context_t* ctx) { kk_assert_internal(kk_datatype_is_ptr(d)); - if (kk_unlikely(kk_datatype_is_singleton(d))) { + if kk_unlikely(kk_datatype_is_singleton(d)) { // todo: why is this test here? return kk_reuse_null; } else { - return kk_block_dropn_reuse(kk_datatype_as_ptr(d), scan_fsize, ctx); + return kk_block_dropn_reuse(kk_datatype_as_ptr(d,ctx), scan_fsize, ctx); } } -static inline kk_reuse_t kk_datatype_reuse(kk_datatype_t d) { - kk_assert_internal(!kk_datatype_is_singleton(d)); - return kk_datatype_as_ptr(d); - /* - if (kk_datatype_is_singleton(d)) { - return kk_reuse_null; - } - else { - return kk_datatype_as_ptr(d); - } - */ +static inline kk_reuse_t kk_datatype_ptr_reuse(kk_datatype_t d, kk_context_t* ctx) { + return kk_datatype_as_ptr(d,ctx); } -static inline void kk_datatype_free(kk_datatype_t d, kk_context_t* ctx) { - kk_assert_internal(kk_datatype_is_ptr(d)); - kk_free(kk_datatype_as_ptr(d),ctx); - /* - if (kk_datatype_is_ptr(d)) { - kk_free(kk_datatype_as_ptr(d)); - } - */ +static inline void kk_datatype_ptr_free(kk_datatype_t d, kk_context_t* ctx) { + kk_free(kk_datatype_as_ptr(d,ctx), ctx); +} + +static inline void kk_datatype_ptr_decref(kk_datatype_t d, kk_context_t* ctx) { + kk_block_decref(kk_datatype_as_ptr(d,ctx), ctx); +} + +#define kk_datatype_from_base(b,ctx) (kk_datatype_from_ptr(&(b)->_block,ctx)) +#define kk_datatype_from_constructor(b,ctx) (kk_datatype_from_base(&(b)->_base,ctx)) +#define kk_datatype_as(tp,v,ctx) (kk_block_as(tp,kk_datatype_as_ptr(v,ctx))) +#define kk_datatype_as_assert(tp,v,tag,ctx) (kk_block_assert(tp,kk_datatype_as_ptr(v,ctx),tag)) + + +#define kk_datatype_null_init kk_value_null + +static inline kk_datatype_t kk_datatype_null(void) { + kk_datatype_t d = { kk_datatype_null_init }; + return d; +} + +static inline bool kk_datatype_is_null(kk_datatype_t d) { + return kk_datatype_eq(d, kk_datatype_null()); } -static inline void kk_datatype_decref(kk_datatype_t d, kk_context_t* ctx) { +static inline kk_datatype_t kk_datatype_unbox(kk_box_t b) { + kk_datatype_t d = { b.box }; + return d; +} + +static inline kk_datatype_t kk_datatype_ptr_unbox(kk_box_t b) { + kk_datatype_t d = { b.box }; kk_assert_internal(kk_datatype_is_ptr(d)); - kk_block_decref(kk_datatype_as_ptr(d), ctx); - /* - if (kk_datatype_is_ptr(d)) { - kk_block_decref(kk_datatype_as_ptr(d), ctx); - } - */ + return d; } -#define kk_datatype_from_base(b) (kk_datatype_from_ptr(&(b)->_block)) -#define kk_datatype_from_constructor(b) (kk_datatype_from_base(&(b)->_base)) -#define kk_datatype_as(tp,v) (kk_block_as(tp,kk_datatype_as_ptr(v))) -#define kk_datatype_as_assert(tp,v,tag) (kk_block_assert(tp,kk_datatype_as_ptr(v),tag)) +static inline kk_box_t kk_datatype_box(kk_datatype_t d) { + kk_box_t b = { d.dbox }; + return b; +} +static inline kk_box_t kk_datatype_ptr_box(kk_datatype_t d) { + kk_assert_internal(kk_datatype_is_ptr(d)); + kk_box_t b = { d.dbox }; + return b; +} -#define kk_define_static_datatype(decl,kk_struct_tp,name,tag) \ - static kk_struct_tp _static_##name = { { KK_HEADER_STATIC(0,tag) } }; \ - decl kk_struct_tp* name = &_static_##name +static inline kk_datatype_t kk_datatype_unbox_assert(kk_box_t b, kk_tag_t t, kk_context_t* ctx) { + kk_unused_internal(ctx); + kk_unused_internal(t); + kk_datatype_t d = kk_datatype_unbox(b); + kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); + return d; +} -#define kk_define_static_open_datatype(decl,kk_struct_tp,name,otag) /* ignore otag as it is initialized dynamically */ \ - static kk_struct_tp _static_##name = { { KK_HEADER_STATIC(0,KK_TAG_OPEN) }, &kk__static_string_empty._base }; \ - decl kk_struct_tp* name = &_static_##name +static inline kk_datatype_t kk_datatype_ptr_unbox_assert(kk_box_t b, kk_tag_t t, kk_context_t* ctx) { + kk_unused_internal(ctx); + kk_unused_internal(t); + kk_datatype_t d = kk_datatype_ptr_unbox(b); + kk_assert_internal(kk_datatype_has_tag(d, t, ctx)); + return d; +} /*---------------------------------------------------------------------- @@ -978,367 +1234,167 @@ static inline void kk_datatype_decref(kk_datatype_t d, kk_context_t* ctx) { } -/*---------------------------------------------------------------------- - Further includes -----------------------------------------------------------------------*/ +/*-------------------------------------------------------------------------------------- + kk_Unit +--------------------------------------------------------------------------------------*/ // The unit type typedef enum kk_unit_e { kk_Unit = 0 } kk_unit_t; - - -#include "kklib/bits.h" -#include "kklib/box.h" -#include "kklib/integer.h" -#include "kklib/bytes.h" -#include "kklib/string.h" -#include "kklib/random.h" -#include "kklib/os.h" -#include "kklib/thread.h" - - -/*---------------------------------------------------------------------- - TLD operations -----------------------------------------------------------------------*/ - -// Get a thread local unique number. -static inline kk_integer_t kk_gen_unique(kk_context_t* ctx) { - kk_integer_t u = ctx->unique; - ctx->unique = kk_integer_inc(kk_integer_dup(u),ctx); - return u; -} - -kk_decl_export kk_string_t kk_get_host(kk_context_t* ctx); -kk_decl_export void kk_fatal_error(int err, const char* msg, ...); -kk_decl_export void kk_warning_message(const char* msg, ...); -kk_decl_export void kk_info_message(const char* msg, ...); - -static inline void kk_unsupported_external(const char* msg) { - kk_fatal_error(ENOSYS, "unsupported external: %s", msg); -} - - - - -/*-------------------------------------------------------------------------------------- - Value tags ---------------------------------------------------------------------------------------*/ - -// Tag for value types is always an integer -typedef kk_integer_t kk_value_tag_t; - -#define kk_value_tag(tag) (kk_integer_from_small(tag)) - -static inline kk_decl_const bool kk_value_tag_eq(kk_value_tag_t x, kk_value_tag_t y) { - // note: x or y may be box_any so don't assert they are smallints - return (_kk_integer_value(x) == _kk_integer_value(y)); -} - -/*-------------------------------------------------------------------------------------- - Optimized support for maybe like datatypes. - We try to avoid allocating for maybe-like types. First we define maybe as a value - type (in std/core/types) and thus a Just is usually passed in 2 registers for the tag - and payload. This does not help though if it becomes boxed, say, a list of maybe - values. In that case we can still avoid allocation through the special TAG_NOTHING - and TAG_JUST tags. If the Just value is neither of those, we just use it directly - without allocation. This way, only nested maybe types (`Just(Just(x))` or `Just(Nothing)`) - are allocated, and sometimes value types like `int32` if these happen to be equal - to `kk_box_Nothing`. ---------------------------------------------------------------------------------------*/ -static inline kk_box_t kk_box_Nothing(void) { - return kk_datatype_box( kk_datatype_from_tag(KK_TAG_NOTHING) ); -} - -static inline bool kk_box_is_Nothing(kk_box_t b) { - return (b.box == kk_datatype_from_tag(KK_TAG_NOTHING).dbox); -} - -static inline bool kk_box_is_Just(kk_box_t b) { - return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b), KK_TAG_JUST)); -} - -static inline bool kk_box_is_maybe(kk_box_t b) { - return (kk_box_is_Just(b) || kk_box_is_Nothing(b)); -} - -typedef struct kk_just_s { - struct kk_block_s _block; - kk_box_t value; -} kk_just_t; - -kk_decl_export kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_context_t* ctx ); - -static inline kk_box_t kk_unbox_Just( kk_box_t b, kk_context_t* ctx ) { - if (kk_box_is_ptr(b)) { - kk_block_t* bl = kk_ptr_unbox(b); - if (kk_unlikely(kk_block_has_tag(bl, KK_TAG_JUST))) { - return kk_unbox_Just_block(bl,ctx); - } - } - // if ctx==NULL we should not change refcounts, if ctx!=NULL we consume the b - return b; -} - -static inline kk_box_t kk_box_Just( kk_box_t b, kk_context_t* ctx ) { - if (kk_likely(!kk_box_is_maybe(b))) { - return b; - } - else { - kk_just_t* just = kk_block_alloc_as(kk_just_t, 1, KK_TAG_JUST, ctx); - just->value = b; - return kk_basetype_box(just); - } -} - -static inline kk_datatype_t kk_datatype_as_Just(kk_box_t b) { - kk_assert_internal(!kk_box_is_maybe(b)); - return kk_datatype_unbox(b); +static inline kk_decl_const kk_box_t kk_unit_box(kk_unit_t u) { + return kk_intf_box((kk_intf_t)u); } -static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { - kk_unused(ctx); - kk_assert_internal(!kk_datatype_has_singleton_tag(d,KK_TAG_NOTHING)); - if (kk_datatype_is_ptr(d)) { - kk_block_t* b = kk_datatype_as_ptr(d); - if (kk_block_has_tag(b,KK_TAG_JUST)) { - return kk_block_field(b,0); - } - } - return kk_datatype_box(d); +static inline kk_decl_const kk_unit_t kk_unit_unbox(kk_box_t u) { + kk_unused_internal(u); + kk_assert_internal(kk_intf_unbox(u) == (kk_intf_t)kk_Unit || kk_box_is_any(u)); + return kk_Unit; // (kk_unit_t)kk_enum_unbox(u); } /*-------------------------------------------------------------------------------------- Functions --------------------------------------------------------------------------------------*/ -#define kk_function_as(tp,fun) kk_basetype_as_assert(tp,fun,KK_TAG_FUNCTION) +#define kk_function_as(tp,fun,ctx) kk_datatype_as_assert(tp,fun,KK_TAG_FUNCTION,ctx) #define kk_function_alloc_as(tp,scan_fsize,ctx) kk_block_alloc_as(tp,scan_fsize,KK_TAG_FUNCTION,ctx) -#define kk_function_call(restp,argtps,f,args) ((restp(*)argtps)(kk_cfun_ptr_unbox(f->fun)))args -#define kk_define_static_function(name,cfun,ctx) \ - static struct kk_function_s _static_##name = { { KK_HEADER_STATIC(0,KK_TAG_FUNCTION) }, { ~KK_UP(0) } }; /* must be box_null */ \ - kk_function_t name = &_static_##name; \ - if (kk_box_eq(name->fun,kk_box_null)) { name->fun = kk_cfun_ptr_box((kk_cfun_ptr_t)&cfun,ctx); } // initialize on demand so it can be boxed properly +#define kk_function_call(restp,argtps,f,args,ctx) ((restp(*)argtps)(kk_kkfun_ptr_unbox(kk_datatype_as_assert(struct kk_function_s*,f,KK_TAG_FUNCTION,ctx)->fun,ctx)))args +#if (KK_COMPRESS==0) +#define kk_define_static_function(name,cfun,ctx) \ + static struct kk_function_s _static_##name = { { KK_HEADER_STATIC(0,KK_TAG_FUNCTION) }, { kk_box_null_init } }; /* must be box_null */ \ + struct kk_function_s* const _##name = &_static_##name; \ + kk_function_t name = { (kk_intb_t)_##name }; \ + if (kk_box_eq(_##name->fun,kk_box_null())) { _##name->fun = kk_kkfun_ptr_box(&cfun,ctx); } // initialize on demand we can encode the field */ +#else +// for a compressed heap, allocate static functions once in the heap on demand; these are never deallocated +#define kk_define_static_function(name,cfun,ctx) \ + static kk_function_t name = { kk_datatype_null_init }; \ + if (kk_datatype_is_null(name)) { \ + struct kk_function_s* _fun = kk_block_alloc_as(struct kk_function_s, 1, KK_TAG_FUNCTION, ctx); \ + _fun->fun = kk_kkfun_ptr_box(&cfun, ctx); \ + name = kk_datatype_from_base(_fun,ctx); \ + } +#endif kk_function_t kk_function_id(kk_context_t* ctx); kk_function_t kk_function_null(kk_context_t* ctx); +bool kk_function_is_null(kk_function_t f, kk_context_t* ctx); -static inline kk_decl_pure kk_function_t kk_function_unbox(kk_box_t v) { - return kk_basetype_unbox_as_assert(kk_function_t, v, KK_TAG_FUNCTION); +static inline kk_decl_pure kk_function_t kk_function_unbox(kk_box_t v, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_ptr_unbox(v); } -static inline kk_decl_pure kk_box_t kk_function_box(kk_function_t d) { - return kk_basetype_box(d); +static inline kk_decl_pure kk_box_t kk_function_box(kk_function_t d, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_ptr_box(d); } -static inline kk_decl_pure bool kk_function_is_unique(kk_function_t f) { - return kk_block_is_unique(&f->_block); +static inline kk_decl_pure bool kk_function_is_unique(kk_function_t f, kk_context_t* ctx) { + return kk_datatype_ptr_is_unique(f,ctx); } static inline void kk_function_drop(kk_function_t f, kk_context_t* ctx) { - kk_basetype_drop_assert(f, KK_TAG_FUNCTION, ctx); + kk_datatype_ptr_drop_assert(f, KK_TAG_FUNCTION, ctx); } -static inline kk_function_t kk_function_dup(kk_function_t f) { - return kk_basetype_dup_assert(kk_function_t, f, KK_TAG_FUNCTION); +static inline kk_function_t kk_function_dup(kk_function_t f, kk_context_t* ctx) { + return kk_datatype_ptr_dup_assert(f, KK_TAG_FUNCTION, ctx); } - /*-------------------------------------------------------------------------------------- - Vector + Constructor contexts (Further primitives are defined in `lib/std/core/types-cctx-inline.h`) --------------------------------------------------------------------------------------*/ -typedef struct kk_vector_large_s { // always use a large block for a vector so the offset to the elements is fixed - struct kk_block_large_s _base; - kk_box_t vec[1]; // vec[(large_)scan_fsize - 1] -} *kk_vector_large_t; - +#define kk_field_index_of(contp,field_name) kk_field_index_at(offsetof(contp,field_name)) -static inline kk_decl_const kk_vector_t kk_vector_empty(void) { - return kk_datatype_from_tag((kk_tag_t)1); +static inline kk_cpath_t kk_field_index_at( size_t field_offset ) { + kk_assert_internal((field_offset % sizeof(kk_box_t)) == 0); + const size_t field_index = (field_offset - sizeof(kk_header_t)) / sizeof(kk_box_t); + kk_assert_internal(field_index <= KK_SCAN_FSIZE_MAX - 2); + return (kk_cpath_t)(1 + field_index); } -static inline kk_decl_pure kk_vector_large_t kk_vector_as_large_borrow(kk_vector_t v) { - if (kk_datatype_is_singleton(v)) { - return NULL; +#define kk_set_cpath(contp,con,field_name) kk_set_cpath_at( &(con)->_base._block, kk_field_index_of(contp,field_name) ) +static inline void kk_set_cpath_at( kk_block_t* b, kk_cpath_t cpath ) { + kk_assert_internal(cpath >= 0 && cpath <= KK_CPATH_MAX); + b->header._field_idx = (uint8_t)cpath; } - else { - return kk_datatype_as_assert(kk_vector_large_t, v, KK_TAG_VECTOR); - } -} - -static inline void kk_vector_drop(kk_vector_t v, kk_context_t* ctx) { - kk_datatype_drop(v, ctx); -} -static inline kk_vector_t kk_vector_dup(kk_vector_t v) { - return kk_datatype_dup(v); -} - -static inline kk_vector_t kk_vector_alloc_uninit(kk_ssize_t length, kk_box_t** buf, kk_context_t* ctx) { - if (kk_unlikely(length<=0)) { - if (buf != NULL) *buf = NULL; - return kk_vector_empty(); - } - else { - kk_vector_large_t v = (kk_vector_large_t)kk_block_large_alloc( - kk_ssizeof(struct kk_vector_large_s) + (length-1)*kk_ssizeof(kk_box_t), // length-1 as the vector_large_s already includes one element - length + 1, // +1 to include the kk_large_scan_fsize field itself - KK_TAG_VECTOR, ctx); - if (buf != NULL) *buf = &v->vec[0]; - return kk_datatype_from_base(&v->_base); - } -} - -kk_decl_export void kk_vector_init_borrow(kk_vector_t _v, kk_ssize_t start, kk_box_t def, kk_context_t* ctx); -kk_decl_export kk_vector_t kk_vector_realloc(kk_vector_t vec, kk_ssize_t newlen, kk_box_t def, kk_context_t* ctx); -kk_decl_export kk_vector_t kk_vector_copy(kk_vector_t vec, kk_context_t* ctx); - -static inline kk_vector_t kk_vector_alloc(kk_ssize_t length, kk_box_t def, kk_context_t* ctx) { - kk_vector_t v = kk_vector_alloc_uninit(length, NULL, ctx); - kk_vector_init_borrow(v, 0, def, ctx); - return v; -} - -static inline kk_box_t* kk_vector_buf_borrow(kk_vector_t vd, kk_ssize_t* len) { - kk_vector_large_t v = kk_vector_as_large_borrow(vd); - if (kk_unlikely(v==NULL)) { - if (len != NULL) *len = 0; - return NULL; - } - else { - if (len != NULL) { - *len = (kk_ssize_t)kk_intf_unbox(v->_base.large_scan_fsize) - 1; // exclude the large scan_fsize field itself - kk_assert_internal(*len + 1 == kk_block_scan_fsize(&v->_base._block)); - kk_assert_internal(*len > 0); - } - return &(v->vec[0]); - } -} - -static inline kk_decl_pure kk_ssize_t kk_vector_len_borrow(const kk_vector_t v) { - kk_ssize_t len; - kk_vector_buf_borrow(v, &len); - return len; -} - -static inline kk_ssize_t kk_vector_len(const kk_vector_t v, kk_context_t* ctx) { - kk_ssize_t len = kk_vector_len_borrow(v); - kk_vector_drop(v, ctx); - return len; -} - -static inline kk_box_t kk_vector_at_borrow(const kk_vector_t v, kk_ssize_t i) { - kk_assert(i < kk_vector_len_borrow(v)); - kk_box_t res = kk_box_dup(kk_vector_buf_borrow(v, NULL)[i]); - return res; -} +#if !defined(KK_HAS_MALLOC_COPY) +#define KK_CCTX_NO_CONTEXT_PATH +#else -static inline kk_decl_const kk_box_t kk_vector_box(kk_vector_t v, kk_context_t* ctx) { - kk_unused(ctx); - return kk_datatype_box(v); -} +// functional context application by copying along the context path and attaching `child` at the hole. +kk_decl_export kk_box_t kk_cctx_copy_apply( kk_box_t res, kk_box_t* holeptr, kk_box_t child, kk_context_t* ctx); -static inline kk_decl_const kk_vector_t kk_vector_unbox(kk_box_t v, kk_context_t* ctx) { - kk_unused(ctx); - return kk_datatype_unbox(v); +// depricated: +// set the context path. +// update the field_idx with the field index + 1 that is along the context path, and return `d` as is. +static inline kk_datatype_t kk_cctx_setcp(kk_datatype_t d, size_t field_offset, kk_context_t* ctx) { + kk_assert_internal((field_offset % sizeof(kk_box_t)) == 0); + kk_assert_internal(kk_datatype_is_ptr(d)); + const size_t field_index = (field_offset - sizeof(kk_header_t)) / sizeof(kk_box_t); + kk_assert_internal(field_index <= KK_SCAN_FSIZE_MAX - 2); + kk_block_field_idx_set( kk_datatype_as_ptr(d,ctx), 1 + (uint8_t)field_index); + return d; } +#endif - -/*-------------------------------------------------------------------------------------- - References ---------------------------------------------------------------------------------------*/ -typedef struct kk_ref_s { - kk_block_t _block; - _Atomic(uintptr_t) value; // kk_box_t -} *kk_ref_t; -kk_decl_export kk_box_t kk_ref_get_thread_shared(kk_ref_t r, kk_context_t* ctx); -kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(kk_ref_t r, kk_box_t value); -kk_decl_export kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx); +/*---------------------------------------------------------------------- + Further primitive datatypes and api's +----------------------------------------------------------------------*/ -static inline kk_decl_const kk_box_t kk_ref_box(kk_ref_t r, kk_context_t* ctx) { - kk_unused(ctx); - return kk_basetype_box(r); -} +#include "kklib/bits.h" +#include "kklib/box.h" -static inline kk_decl_const kk_ref_t kk_ref_unbox(kk_box_t b, kk_context_t* ctx) { - kk_unused(ctx); - return kk_basetype_unbox_as_assert(kk_ref_t, b, KK_TAG_REF); -} +#include "kklib/maybe.h" +#include "kklib/integer.h" +#include "kklib/bytes.h" +#include "kklib/string.h" +#include "kklib/ref.h" +#include "kklib/vector.h" -static inline void kk_ref_drop(kk_ref_t r, kk_context_t* ctx) { - kk_basetype_drop_assert(r, KK_TAG_REF, ctx); -} +#include "kklib/random.h" +#include "kklib/os.h" +#include "kklib/thread.h" +#include "kklib/process.h" // Process info (memory usage, run time etc.) -static inline kk_ref_t kk_ref_dup(kk_ref_t r) { - return kk_basetype_dup_assert(kk_ref_t, r, KK_TAG_REF); -} -static inline kk_ref_t kk_ref_alloc(kk_box_t value, kk_context_t* ctx) { - kk_ref_t r = kk_block_alloc_as(struct kk_ref_s, 1, KK_TAG_REF, ctx); - kk_atomic_store_relaxed(&r->value,value.box); - return r; -} -static inline kk_box_t kk_ref_get(kk_ref_t r, kk_context_t* ctx) { - if (kk_likely(!kk_block_is_thread_shared(&r->_block))) { - // fast path - kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); - kk_box_dup(b); - kk_ref_drop(r,ctx); // TODO: make references borrowed (only get left) - return b; - } - else { - // thread shared - return kk_ref_get_thread_shared(r,ctx); - } -} +/*---------------------------------------------------------------------- + Thread local context operations +----------------------------------------------------------------------*/ -static inline kk_box_t kk_ref_swap_borrow(kk_ref_t r, kk_box_t value) { - if (kk_likely(!kk_block_is_thread_shared(&r->_block))) { - // fast path - kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); - kk_atomic_store_relaxed(&r->value, value.box); - return b; - } - else { - // thread shared - return kk_ref_swap_thread_shared_borrow(r, value); - } +// Get a thread local unique number. +static inline kk_integer_t kk_gen_unique(kk_context_t* ctx) { + kk_integer_t u = ctx->unique; + ctx->unique = kk_integer_inc(kk_integer_dup(u,ctx),ctx); + return u; } +kk_decl_export kk_string_t kk_get_host(kk_context_t* ctx); -static inline kk_unit_t kk_ref_set_borrow(kk_ref_t r, kk_box_t value, kk_context_t* ctx) { - kk_box_t b = kk_ref_swap_borrow(r, value); - kk_box_drop(b, ctx); - return kk_Unit; -} - -// In Koka we can constrain the argument of f to be a local-scope reference. -static inline kk_box_t kk_ref_modify(kk_ref_t r, kk_function_t f, kk_context_t* ctx) { - return kk_function_call(kk_box_t,(kk_function_t,kk_ref_t,kk_context_t*),f,(f,r,ctx)); -} /*-------------------------------------------------------------------------------------- - kk_Unit + Value tags (used for tags in structs) --------------------------------------------------------------------------------------*/ -static inline kk_decl_const kk_box_t kk_unit_box(kk_unit_t u) { - return kk_intf_box((kk_intf_t)u); -} +// Tag for value types is always an integer +typedef kk_integer_t kk_value_tag_t; -static inline kk_decl_const kk_unit_t kk_unit_unbox(kk_box_t u) { - kk_unused_internal(u); - kk_assert_internal( kk_intf_unbox(u) == (kk_intf_t)kk_Unit || kk_box_is_any(u)); - return kk_Unit; // (kk_unit_t)kk_enum_unbox(u); -} +#define kk_value_tag(tag) (kk_integer_from_small(tag)) +static inline kk_decl_const bool kk_value_tag_eq(kk_value_tag_t x, kk_value_tag_t y) { + // note: x or y may be box_any so don't assert they are smallints + return (_kk_integer_value(x) == _kk_integer_value(y)); +} #endif // include guard diff --git a/kklib/include/kklib/atomic.h b/kklib/include/kklib/atomic.h index f60c7c01b..c93bc987b 100644 --- a/kklib/include/kklib/atomic.h +++ b/kklib/include/kklib/atomic.h @@ -25,6 +25,13 @@ #define kk_memory_order_t memory_order #endif +// ATOMIC_VAR_INIT is deprecated in C17 and C++20 +#if (defined(KK_C17) || defined(KK_CPP20) || (__cplusplus >= 201803L)) +#define KK_ATOMIC_VAR_INIT(x) x +#else +#define KK_ATOMIC_VAR_INIT(x) ATOMIC_VAR_INIT(x) +#endif + #define kk_atomic_load_relaxed(p) kk_atomic(load_explicit)(p,kk_memory_order(relaxed)) #define kk_atomic_load_acquire(p) kk_atomic(load_explicit)(p,kk_memory_order(acquire)) #define kk_atomic_store_relaxed(p,x) kk_atomic(store_explicit)(p,x,kk_memory_order(relaxed)) diff --git a/kklib/include/kklib/bits.h b/kklib/include/kklib/bits.h index fd3dff4fc..f3f19bd6b 100644 --- a/kklib/include/kklib/bits.h +++ b/kklib/include/kklib/bits.h @@ -3,7 +3,7 @@ #define KK_BITS_H /*--------------------------------------------------------------------------- - Copyright 2020-2021, Microsoft Research, Daan Leijen. + Copyright 2020-2023, Microsoft Research, Daan Leijen. This is free software; you can redistribute it and/or modify it under the terms of the Apache License, Version 2.0. A copy of the License can be @@ -110,93 +110,181 @@ static inline kk_uintx_t kk_bits_rotr(kk_uintx_t x, kk_uintx_t shift) { /* ----------------------------------------------------------- - `clz` count leading zero bits - `ctz` count trailing zero bits + `clz` count leading zero bits (32/64 for zero) + `ctz` count trailing zero bits (32/64 for zero) + `ffs` find first set: bit-index + 1, or 0 for zero + `fls` find last set: bit-index + 1, or 0 for zero ----------------------------------------------------------- */ #if defined(__GNUC__) -static inline uint8_t kk_bits_clz32(uint32_t x) { +static inline int kk_bits_clz32(uint32_t x) { return (x==0 ? 32 : __builtin32(clz)(x)); } -static inline uint8_t kk_bits_ctz32(uint32_t x) { +static inline int kk_bits_ctz32(uint32_t x) { return (x==0 ? 32 : __builtin32(ctz)(x)); } +static inline int kk_bits_ffs32(uint32_t x) { + return __builtin32(ffs)(x); +} #if (KK_INTX_SIZE >= 8) -#define HAS_BITS_CLZ64 -static inline uint8_t kk_bits_clz64(uint64_t x) { +#define KK_HAS_BITS_CLZ64 +static inline int kk_bits_clz64(uint64_t x) { return (x==0 ? 64 : __builtin64(clz)(x)); } -static inline uint8_t kk_bits_ctz64(uint64_t x) { +static inline int kk_bits_ctz64(uint64_t x) { return (x==0 ? 64 : __builtin64(ctz)(x)); } +static inline int kk_bits_ffs64(uint64_t x) { + return __builtin64(ffs)(x); +} #endif -#elif defined(_MSC_VER) && !defined(__clang_msvc__) && (defined(_M_ARM64) || defined(_M_ARM) || defined(_M_X64) || defined(_M_IX86)) +#elif defined(_MSC_VER) && (defined(_M_ARM64) || defined(_M_ARM) || defined(_M_X64) || defined(_M_IX86)) #include - -#if defined(_M_X64) || defined(_M_IX86) -extern bool kk_has_lzcnt; // initialized in runtime.c -extern bool kk_has_tzcnt; -#endif - -static inline uint8_t kk_bits_clz32(uint32_t x) { - #if defined(_M_X64) || defined(_M_IX86) - if (kk_likely(kk_has_lzcnt)) return (uint8_t)__lzcnt(x); - #endif +static inline int kk_bits_clz32(uint32_t x) { + unsigned long idx; + return (_BitScanReverse(&idx, x) ? 31 - (int)idx : 32); +} +static inline int kk_bits_ctz32(uint32_t x) { unsigned long idx; - return (_BitScanReverse(&idx, x) ? 31 - (uint8_t)idx : 32); + return (_BitScanForward(&idx, x) ? (int)idx : 32); } -static inline uint8_t kk_bits_ctz32(uint32_t x) { - #if defined(_M_X64) || defined(_M_IX86) - if (kk_likely(kk_has_tzcnt)) return (uint8_t)_tzcnt_u32(x); - #endif +static inline int kk_bits_ffs32(uint32_t x) { unsigned long idx; - return (_BitScanForward(&idx, x) ? (uint8_t)idx : 32); + return (_BitScanForward(&idx, x) ? 1 + (int)idx : 0); } #if (KK_INTX_SIZE >= 8) -#define HAS_BITS_CLZ64 -static inline uint8_t kk_bits_clz64(uint64_t x) { - #if defined(_M_X64) || defined(_M_IX86) - if (kk_likely(kk_has_lzcnt)) return (uint8_t)__lzcnt64(x); - #endif +#define KK_HAS_BITS_CLZ64 +static inline int kk_bits_clz64(uint64_t x) { + unsigned long idx; + return (_BitScanReverse64(&idx, x) ? 63 - (int)idx : 64); +} +static inline int kk_bits_ctz64(uint64_t x) { unsigned long idx; - return (_BitScanReverse64(&idx, x) ? 63 - (uint8_t)idx : 64); + return (_BitScanForward64(&idx, x) ? (int)idx : 64); } -static inline uint8_t kk_bits_ctz64(uint64_t x) { - #if defined(_M_X64) || defined(_M_IX86) - if (kk_likely(kk_has_tzcnt)) return (uint8_t)_tzcnt_u64(x); - #endif +static inline int kk_bits_ffs64(uint64_t x) { unsigned long idx; - return (_BitScanForward64(&idx, x) ? (uint8_t)idx : 64); + return (_BitScanForward64(&idx, x) ? 1 + (int)idx : 0); } #endif #else #define KK_BITS_USE_GENERIC_CTZ_CLZ 1 -kk_decl_export uint8_t kk_bits_ctz32(uint32_t x); -kk_decl_export uint8_t kk_bits_clz32(uint32_t x); +kk_decl_export int kk_bits_ctz32(uint32_t x); +kk_decl_export int kk_bits_clz32(uint32_t x); +static inline int kk_bits_ffs32(uint32_t x) { + return (x == 0 ? 0 : 1 + kk_bits_ctz32(x)); +} #endif -#ifndef HAS_BITS_CLZ64 -#define HAS_BITS_CLZ64 -static inline uint8_t kk_bits_clz64(uint64_t x) { - uint8_t cnt = kk_bits_clz32((uint32_t)(x >> 32)); +#ifndef KK_HAS_BITS_CLZ64 +#define KK_HAS_BITS_CLZ64 +static inline int kk_bits_clz64(uint64_t x) { + int cnt = kk_bits_clz32((uint32_t)(x >> 32)); if (cnt < 32) return cnt; return (32 + kk_bits_clz32((uint32_t)x)); } -static inline uint8_t kk_bits_ctz64(uint64_t x) { - uint8_t cnt = kk_bits_ctz32((uint32_t)x); +static inline int kk_bits_ctz64(uint64_t x) { + int cnt = kk_bits_ctz32((uint32_t)x); if (cnt < 32) return cnt; return (32 + kk_bits_ctz32((uint32_t)(x >> 32))); } +static inline int kk_bits_ffs64(uint64_t x) { + if (x == 0) return 0; + int idx = kk_bits_ffs32((uint32_t)x); + if (idx > 0) return idx; + return (32 + kk_bits_ffs32((uint32_t)(x >> 32))); +} #endif -static inline uint8_t kk_bits_clz(kk_uintx_t x) { +static inline int kk_bits_fls32(uint32_t x) { + return (32 - kk_bits_clz32(x)); +} +static inline int kk_bits_fls64(uint64_t x) { + return (64 - kk_bits_clz64(x)); +} + +static inline int kk_bits_clz(kk_uintx_t x) { return kk_bitsx(clz)(x); } -static inline uint8_t kk_bits_ctz(kk_uintx_t x) { +static inline int kk_bits_ctz(kk_uintx_t x) { return kk_bitsx(ctz)(x); } +static inline int kk_bits_ffs(kk_uintx_t x) { + return kk_bitsx(ffs)(x); +} +static inline int kk_bits_fls(kk_uintx_t x) { + return kk_bitsx(fls)(x); +} + +/* ----------------------------------------------------------- + count leading redundant sign bits (i.e. the number of bits + following the most significant bit that are identical to it). + + clrsb31(INT32_MAX) == 0 + ... + clrsb31(1) == 30 + clrsb32(0) == 31 + clrsb32(-1) == 31 + clrsb32(-2) == 30 + ... + clrsb32(INT32_MIN) = 0 +----------------------------------------------------------- */ + +static inline int kk_bits_clrsb32(int32_t x) { + const int32_t i = kk_sar32(x, 31) ^ x; + if (i == 0) return 31; // x==0 or x==1 + else return kk_bits_clz32(i) - 1; +} + +static inline int kk_bits_clrsb64(int64_t x) { + const int64_t i = kk_sar64(x, 63) ^ x; + if (i == 0) return 63; // x==0 or x==1 + else return kk_bits_clz64(i) - 1; +} + +static inline int kk_bits_clrsb(kk_intx_t x) { + return kk_bitsx(clrsb)(x); +} + + +/* ----------------------------------------------------------- + clear least-significant bit +----------------------------------------------------------- */ + +#define _kk_bits_clear_lsb(x) ((x) & ((x)-1)) + +static inline uint32_t kk_bits_clear_lsb32(uint32_t x) { + return _kk_bits_clear_lsb(x); +} + +static inline uint64_t kk_bits_clear_lsb64(uint64_t x) { + return _kk_bits_clear_lsb(x); +} + +static inline kk_uintx_t kk_bits_clear_lsb(kk_uintx_t x) { + return kk_bitsx(clear_lsb)(x); +} + +/* ----------------------------------------------------------- + keep (only) least-significant bit +----------------------------------------------------------- */ + +#define _kk_bits_only_keep_lsb(x) ((x) & (~(x)+1)) + +static inline uint32_t kk_bits_only_keep_lsb32(uint32_t x) { + return _kk_bits_only_keep_lsb(x); +} + +static inline uint64_t kk_bits_only_keep_lsb64(uint64_t x) { + return _kk_bits_only_keep_lsb(x); +} + +static inline kk_uintx_t kk_bits_only_keep_lsb(kk_uintx_t x) { + return kk_bitsx(only_keep_lsb)(x); +} + /* ----------------------------------------------------------- Byte operations @@ -276,60 +364,60 @@ static inline uint8_t kk_bits_byte_sum(kk_uintx_t x) { /* --------------------------------------------------------------- - kk_bits_count: population count / hamming weight (count set bits) + kk_bits_popcount: population count / hamming weight (count set bits) see ------------------------------------------------------------------ */ -kk_decl_export uint32_t kk_bits_generic_count32(uint32_t x); -kk_decl_export uint64_t kk_bits_generic_count64(uint64_t x); +kk_decl_export int kk_bits_generic_popcount32(uint32_t x); +kk_decl_export int kk_bits_generic_popcount64(uint64_t x); #if defined(_MSC_VER) && (defined(_M_X64) || defined(_M_IX86)) #include extern bool kk_has_popcnt; // initialized in runtime.c -static inline uint32_t kk_bits_count32(uint32_t x) { - if (kk_has_popcnt) return __popcnt(x); - return kk_bits_generic_count32(x); +static inline int kk_bits_popcount32(uint32_t x) { + if (kk_has_popcnt) return (int)__popcnt(x); + return kk_bits_generic_popcount32(x); } #if (KK_INTX_SIZE >= 8) -#define HAS_BITS_COUNT64 -static inline uint64_t kk_bits_count64(uint64_t x) { - if (kk_has_popcnt) return __popcnt64(x); - return kk_bits_generic_count64(x); +#define KK_HAS_BITS_POPCOUNT64 +static inline int kk_bits_popcount64(uint64_t x) { + if (kk_has_popcnt) return (int)__popcnt64(x); + return kk_bits_generic_popcount64(x); } #endif #elif defined(__GNUC__) -static inline uint32_t kk_bits_count32(uint32_t x) { +static inline int kk_bits_popcount32(uint32_t x) { return __builtin32(popcount)(x); } #if (KK_INTX_SIZE >= 8) -#define HAS_BITS_COUNT64 -static inline uint64_t kk_bits_count64(uint64_t x) { +#define KK_HAS_BITS_POPCOUNT64 +static inline int kk_bits_popcount64(uint64_t x) { return __builtin64(popcount)(x); } #endif #else -static inline uint32_t kk_bits_count32(uint32_t x) { - return kk_bits_generic_count32(x); +static inline int kk_bits_popcount32(uint32_t x) { + return kk_bits_generic_popcount32(x); } -#define HAS_BITS_COUNT64 -static inline uint64_t kk_bits_count64(uint64_t x) { - return kk_bits_generic_count64(x); +#define KK_HAS_BITS_POPCOUNT64 +static inline int kk_bits_popcount64(uint64_t x) { + return kk_bits_generic_popcount64(x); } #endif -#ifndef HAS_BITS_COUNT64 -#define HAS_BITS_COUNT64 -static inline uint64_t kk_bits_count64(uint64_t x) { - return ((uint64_t)kk_bits_count32((uint32_t)x) + kk_bits_count32((uint32_t)(x>>32))); +#ifndef KK_HAS_BITS_POPCOUNT64 +#define KK_HAS_BITS_POPCOUNT64 +static inline int kk_bits_popcount64(uint64_t x) { + return (kk_bits_popcount32((uint32_t)x) + kk_bits_popcount32((uint32_t)(x>>32))); } #endif -static inline kk_uintx_t kk_bits_count(kk_uintx_t x) { - return kk_bitsx(count)(x); +static inline int kk_bits_popcount(kk_uintx_t x) { + return kk_bitsx(popcount)(x); } @@ -470,53 +558,88 @@ static inline double kk_bits_to_double(uint64_t x) { /* --------------------------------------------------------------- - Parity: returns `kk_bits_count(x) % 2` + Parity: returns `kk_bits_popcount(x) % 2` see ------------------------------------------------------------------ */ #if defined(_MSC_VER) && (defined(_M_X64) || defined(_M_IX86)) -static inline bool kk_bits_count_is_even32(uint32_t x) { - return ((kk_bits_count32(x) & 1) == 0); +static inline bool kk_bits_popcount_is_even32(uint32_t x) { + return ((kk_bits_popcount32(x) & 1) == 0); } -static inline bool kk_bits_count_is_even64(uint64_t x) { - return ((kk_bits_count64(x) & 1) == 0); +static inline bool kk_bits_popcount_is_even64(uint64_t x) { + return ((kk_bits_popcount64(x) & 1) == 0); } #elif defined(__GNUC__) -static inline bool kk_bits_count_is_even32(uint32_t x) { +static inline bool kk_bits_popcount_is_even32(uint32_t x) { return (__builtin32(parity)(x) == 0); } -static inline bool kk_bits_count_is_even64(uint64_t x) { +static inline bool kk_bits_popcount_is_even64(uint64_t x) { return (__builtin64(parity)(x) == 0); } #else -static inline bool kk_bits_count_is_even32(uint32_t x) { +static inline bool kk_bits_popcount_is_even32(uint32_t x) { x ^= x >> 16; x ^= x >> 8; x ^= x >> 4; x &= 0x0F; return (((0x6996 >> x) & 1) == 0); // 0x6996 = 0b0110100110010110 == "mini" 16 bit lookup table with a bit set if the value has non-even parity } -static inline bool kk_bits_count_is_even64(uint64_t x) { - x ^= x >> 32; - return kk_bits_count_is_even32((uint32_t)x); +static inline bool kk_bits_popcount_is_even64(uint64_t x) { + x ^= (x >> 32); + return kk_bits_popcount_is_even32((uint32_t)x); } #endif -static inline bool kk_bits_count_is_even(kk_uintx_t x) { - return kk_bitsx(count_is_even)(x); +static inline bool kk_bits_popcount_is_even(kk_uintx_t x) { + return kk_bitsx(popcount_is_even)(x); } /* --------------------------------------------------------------- Digits in a decimal representation ------------------------------------------------------------------ */ -kk_decl_export uint8_t kk_bits_digits32(uint32_t x); -kk_decl_export uint8_t kk_bits_digits64(uint64_t x); +kk_decl_export int kk_bits_digits32(uint32_t x); +kk_decl_export int kk_bits_digits64(uint64_t x); -static inline uint8_t kk_bits_digits(kk_uintx_t x) { +static inline int kk_bits_digits(kk_uintx_t x) { return kk_bitsx(digits)(x); } +/* --------------------------------------------------------------- + midpoint(x,y): the average of x and y, rounded towards x. + note: written to avoid overflow and UB. See also + +------------------------------------------------------------------ */ + +static inline int32_t kk_bits_midpoint32( int32_t x, int32_t y ) { + if kk_likely(x <= y) return x + (int32_t)(((uint32_t)y - (uint32_t)x)/2); + else return x - (int32_t)(((uint32_t)x - (uint32_t)y)/2); +} + +static inline int64_t kk_bits_midpoint64(int64_t x, int64_t y) { + if kk_likely(x <= y) return x + (int64_t)(((uint64_t)y - (uint64_t)x)/2); + else return x - (int64_t)(((uint64_t)x - (uint64_t)y)/2); +} + +static inline kk_intx_t kk_bits_midpoint(kk_intx_t x, kk_intx_t y) { + return kk_bitsx(midpoint)(x, y); +} + +static inline uint32_t kk_bits_umidpoint32( uint32_t x, uint32_t y ) { + if kk_likely(x <= y) return (x + (y-x)/2); + else return (x - (x-y)/2); +} + +static inline uint64_t kk_bits_umidpoint64( uint64_t x, uint64_t y ) { + if kk_likely(x <= y) return (x + (y-x)/2); + else return (x - (x-y)/2); +} + +static inline kk_uintx_t kk_bits_umidpoint( kk_uintx_t x, kk_uintx_t y ) { + return kk_bitsx(umidpoint)(x,y); +} + + #endif // include guard diff --git a/kklib/include/kklib/box.h b/kklib/include/kklib/box.h index 1a71ca36b..58e5dedbb 100644 --- a/kklib/include/kklib/box.h +++ b/kklib/include/kklib/box.h @@ -41,68 +41,67 @@ On 64-bit, We can encode half of the doubles as values by saving 1 bit; Possible ----------------------------------------------------------------*/ #if (KK_INTPTR_SIZE == 8) -#define KK_BOX_DOUBLE64 (1) // box doubles on 64-bit using strategy A1 by default +#define KK_BOX_DOUBLE64 (1) // box doubles on 64-bit using strategy A1 by default // #define KK_BOX_DOUBLE64 (2) // heap allocate negative doubles on 64-bit (strategy A2) // #define KK_BOX_DOUBLE64 (0) // heap allocate doubles interpreted as int64_t (strategy A0) #else #define KK_BOX_DOUBLE64 (0) #endif -#define KK_BOXED_VALUE_BITS (KK_INTF_BITS-1) // note: can be less than intptr_t on CHERI architectures for example - -#define KK_MAX_BOXED_INT ((kk_intf_t)KK_INTF_MAX >> (KK_INTF_BITS - KK_BOXED_VALUE_BITS)) -#define KK_MIN_BOXED_INT (- KK_MAX_BOXED_INT - 1) - -#define KK_MAX_BOXED_UINT ((kk_uintf_t)KK_UINTF_MAX >> (KK_INTF_BITS - KK_BOXED_VALUE_BITS)) -#define KK_MIN_BOXED_UINT (0) - // Forward declarations static inline bool kk_box_is_ptr(kk_box_t b); -static inline kk_block_t* kk_ptr_unbox(kk_box_t b); -static inline kk_box_t kk_ptr_box(const kk_block_t* p); +static inline kk_block_t* kk_ptr_unbox(kk_box_t b, kk_context_t* ctx); +static inline kk_box_t kk_ptr_box(const kk_block_t* p, kk_context_t* ctx); static inline kk_intf_t kk_intf_unbox(kk_box_t v); static inline kk_box_t kk_intf_box(kk_intf_t i); // Low level access -static inline kk_box_t _kk_box_new_ptr(const kk_block_t* p) { - kk_box_t b = { (uintptr_t)p }; +static inline kk_box_t kk_box_from_ptr(const kk_block_t* p, kk_context_t* ctx) { + kk_box_t b = { kk_ptr_encode((kk_ptr_t)p,ctx) }; return b; } -static inline kk_box_t _kk_box_new_value(kk_uintf_t u) { - kk_box_t b = { u }; + +static inline kk_box_t kk_box_from_value(kk_intf_t i, int extra_shift ) { + kk_box_t b = { kk_intf_encode(i,extra_shift) }; return b; } -static inline kk_uintf_t _kk_box_value(kk_box_t b) { - return (kk_uintf_t)(b.box); +static inline kk_ptr_t kk_box_to_ptr(kk_box_t b, kk_context_t* ctx) { + return kk_ptr_decode(b.box, ctx); } -static inline kk_ptr_t _kk_box_ptr(kk_box_t b) { - return (kk_ptr_t)(b.box); + +static inline kk_intf_t kk_box_to_value(kk_box_t b, int extra_shift) { + return kk_intf_decode(b.box, extra_shift); } + // query static inline bool kk_box_is_ptr(kk_box_t b) { - return ((_kk_box_value(b)&1)==0); + return kk_is_ptr(b.box); } + static inline bool kk_box_is_value(kk_box_t b) { - return ((_kk_box_value(b)&1)!=0); + return kk_is_value(b.box); } + // Are two boxed representations equal? static inline bool kk_box_eq(kk_box_t b1, kk_box_t b2) { return (b1.box == b2.box); } -// We cannot store NULL as a pointer (`kk_ptr_t`); use `box_null` instead -#define kk_box_null (_kk_box_new_ptr((kk_ptr_t)(~KK_UP(0)))) // -1 value - // null initializer -#define kk_box_null_init {~KK_UP(0)} +#define kk_box_null_init kk_value_null +// We cannot store NULL as a pointer (`kk_ptr_t`); use `kk_box_null()` instead +static inline kk_box_t kk_box_null(void) { + kk_box_t b = { kk_box_null_init }; + return b; +} static inline bool kk_box_is_null(kk_box_t b) { - return (b.box == kk_box_null.box); + return (b.box == kk_box_null_init); } static inline bool kk_box_is_non_null_ptr(kk_box_t v) { @@ -111,87 +110,114 @@ static inline bool kk_box_is_non_null_ptr(kk_box_t v) { } static inline bool kk_box_is_any(kk_box_t b) { - return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b), KK_TAG_BOX_ANY)); + return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b,kk_get_context()), KK_TAG_BOX_ANY)); +} + +static inline kk_box_t kk_box_from_potential_null_ptr(kk_block_t* p, kk_context_t* ctx) { + if (p == NULL) return kk_box_null(); + else return kk_box_from_ptr(p,ctx); } +static inline kk_block_t* kk_box_to_potential_null_ptr(kk_box_t b, kk_context_t* ctx) { + if (kk_box_is_null(b)) return NULL; + else return kk_box_to_ptr(b, ctx); +} /*---------------------------------------------------------------- Box pointers and kk_intf_t ----------------------------------------------------------------*/ -static inline kk_ptr_t kk_ptr_unbox(kk_box_t v) { +static inline kk_ptr_t kk_ptr_unbox(kk_box_t v, kk_context_t* ctx) { kk_assert_internal(kk_box_is_ptr(v) || kk_box_is_any(v)); kk_assert_internal(v.box != 0); // no NULL pointers allowed - return _kk_box_ptr(v); + return kk_box_to_ptr(v, ctx); } -static inline kk_box_t kk_ptr_box(const kk_block_t* p) { +static inline kk_box_t kk_ptr_box(const kk_block_t* p, kk_context_t* ctx) { kk_assert_internal(((uintptr_t)p & 0x03) == 0); // check alignment kk_assert_internal(p != NULL); // block should never be NULL - return _kk_box_new_ptr(p); + return kk_box_from_ptr(p,ctx); } -static inline kk_uintf_t kk_uintf_unbox(kk_box_t b) { - kk_assert_internal(kk_box_is_value(b) || kk_box_is_any(b)); - return kk_shrf(_kk_box_value(b), 1); +static inline kk_intf_t kk_intf_unbox(kk_box_t v) { + kk_assert_internal(kk_box_is_value(v) || kk_box_is_any(v)); + return kk_box_to_value(v, 0); } -static inline kk_box_t kk_uintf_box(kk_uintf_t u) { - kk_assert_internal(u <= KK_MAX_BOXED_UINT); - return _kk_box_new_value((u << 1)|1); +static inline kk_box_t kk_intf_box(kk_intf_t i) { + return kk_box_from_value(i, 0); } -static inline kk_intf_t kk_intf_unbox(kk_box_t v) { - kk_assert_internal(kk_box_is_value(v) || kk_box_is_any(v)); - return kk_sarf((kk_intf_t)_kk_box_value(v), 1); // preserve sign + +static inline kk_uintf_t kk_uintf_unbox(kk_box_t b) { + kk_assert_internal(kk_box_is_value(b) || kk_box_is_any(b)); + kk_intf_t i = kk_intf_unbox(b); + return (kk_uintf_t)kk_shrf(kk_shlf(i, KK_TAG_BITS), KK_TAG_BITS); } -static inline kk_box_t kk_intf_box(kk_intf_t i) { - kk_assert_internal(i >= KK_MIN_BOXED_INT && i <= KK_MAX_BOXED_INT); - return _kk_box_new_value(((kk_uintf_t)i << 1)|1); +static inline kk_box_t kk_uintf_box(kk_uintf_t u) { + kk_assert_internal(u <= KK_UINTF_BOX_MAX(0)); + kk_intf_t i = kk_sarf(kk_shlf((kk_intf_t)u, KK_TAG_BITS), KK_TAG_BITS); + return kk_intf_box(i); } -static inline kk_box_t kk_box_dup(kk_box_t b) { - if (kk_box_is_ptr(b)) kk_block_dup(kk_ptr_unbox(b)); + +static inline kk_box_t kk_box_dup(kk_box_t b, kk_context_t* ctx) { + if (kk_box_is_ptr(b)) { kk_block_dup(kk_ptr_unbox(b, ctx)); } return b; } static inline void kk_box_drop(kk_box_t b, kk_context_t* ctx) { - if (kk_box_is_ptr(b)) kk_block_drop(kk_ptr_unbox(b), ctx); + if (kk_box_is_ptr(b)) { kk_block_drop(kk_ptr_unbox(b, ctx), ctx); } +} + +/*---------------------------------------------------------------- + Borrowing for value types in matches +----------------------------------------------------------------*/ + +typedef enum kk_borrow_e { + KK_OWNED = 0, + KK_BORROWED +} kk_borrow_t; + +static inline bool kk_is_owned(kk_borrow_t borrow) { + return (borrow != KK_BORROWED); +} +static inline bool kk_is_borrowed(kk_borrow_t borrow) { + return (borrow == KK_BORROWED); } /*---------------------------------------------------------------- Integers & Floats ----------------------------------------------------------------*/ -kk_decl_export intptr_t kk_intptr_unbox(kk_box_t v, kk_context_t* ctx); +kk_decl_export intptr_t kk_intptr_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_intptr_box(intptr_t i, kk_context_t* ctx); +kk_decl_export kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx); -kk_decl_export kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx); -#if (KK_INTPTR_SIZE <= 8) -kk_decl_export int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx); +#if (KK_INTF_SIZE <= 8) +kk_decl_export int64_t kk_int64_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_int64_box(int64_t i, kk_context_t* ctx); #else -static inline int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx) { - kk_unused(ctx); - intptr_t i = kk_sarp((intptr_t)v.box, 1); +static inline int64_t kk_int64_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { + kk_unused(ctx); kk_unused(borrow); + kk_intf_t i = kk_intf_unbox(v, ctx); kk_assert_internal((i >= INT64_MIN && i <= INT64_MAX) || kk_box_is_any(v)); return (int64_t)i; } static inline kk_box_t kk_int64_box(int64_t i, kk_context_t* ctx) { kk_unused(ctx); - kk_box_t b = { ((uintptr_t)i << 1) | 1 }; - return b; + return kk_intf_box(i); } #endif -#if (KK_INTPTR_SIZE<=4) -kk_decl_export int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx); +#if (KK_INTF_SIZE<=4) +kk_decl_export int32_t kk_int32_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_int32_box(int32_t i, kk_context_t* ctx); #else -static inline int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx) { - kk_unused(ctx); +static inline int32_t kk_int32_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { + kk_unused(ctx); kk_unused(borrow); kk_intf_t i = kk_intf_unbox(v); kk_assert_internal((i >= INT32_MIN && i <= INT32_MAX) || kk_box_is_any(v)); return (int32_t)(i); @@ -203,12 +229,12 @@ static inline kk_box_t kk_int32_box(int32_t i, kk_context_t* ctx) { } #endif -#if (KK_INTPTR_SIZE<=2) -kk_decl_export int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx); +#if (KK_INTF_SIZE<=2) +kk_decl_export int16_t kk_int16_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx); #else -static inline int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx) { - kk_unused(ctx); +static inline int16_t kk_int16_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { + kk_unused(ctx); kk_unused(borrow); kk_intf_t i = kk_intf_unbox(v); kk_assert_internal((i >= INT16_MIN && i <= INT16_MAX) || kk_box_is_any(v)); return (int16_t)(i); @@ -219,12 +245,12 @@ static inline kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx) { } #endif -#if (KK_INTPTR_SIZE == 8) && KK_BOX_DOUBLE64 +#if (KK_INTF_SIZE == 8) && KK_BOX_DOUBLE64 kk_decl_export kk_box_t kk_double_box(double d, kk_context_t* ctx); -kk_decl_export double kk_double_unbox(kk_box_t b, kk_context_t* ctx); +kk_decl_export double kk_double_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx); #else -static inline double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { - int64_t i = kk_int64_unbox(b, ctx); +static inline double kk_double_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + int64_t i = kk_int64_unbox(b, borrow, ctx); return kk_bits_to_double((uint64_t)i); } static inline kk_box_t kk_double_box(double d, kk_context_t* ctx) { @@ -233,12 +259,12 @@ static inline kk_box_t kk_double_box(double d, kk_context_t* ctx) { } #endif -#if (KK_INTPTR_SIZE == 4) -kk_decl_export float kk_float_unbox(kk_box_t b, kk_context_t* ctx); +#if (KK_INTF_SIZE == 4) +kk_decl_export float kk_float_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx); kk_decl_export kk_box_t kk_float_box(float f, kk_context_t* ctx); #else -static inline float kk_float_unbox(kk_box_t b, kk_context_t* ctx) { - int32_t i = kk_int32_unbox(b, ctx); +static inline float kk_float_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + int32_t i = kk_int32_unbox(b, borrow, ctx); return kk_bits_to_float((uint32_t)i); } static inline kk_box_t kk_float_box(float f, kk_context_t* ctx) { @@ -263,50 +289,39 @@ static inline kk_box_t kk_size_box(size_t i, kk_context_t* ctx) { return kk_ssize_box((kk_ssize_t)i, ctx); } -static inline size_t kk_size_unbox(kk_box_t b, kk_context_t* ctx) { - return (size_t)kk_ssize_unbox(b, ctx); +static inline size_t kk_size_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return (size_t)kk_ssize_unbox(b, borrow, ctx); } -static inline kk_block_t* kk_block_unbox(kk_box_t v, kk_tag_t kk_expected_tag ) { +static inline kk_block_t* kk_block_unbox(kk_box_t v, kk_tag_t kk_expected_tag, kk_context_t* ctx ) { kk_unused_internal(kk_expected_tag); - kk_block_t* b = kk_ptr_unbox(v); + kk_block_t* b = kk_ptr_unbox(v,ctx); kk_assert_internal(kk_block_tag(b) == kk_expected_tag); return b; } -static inline kk_box_t kk_block_box(kk_block_t* b) { - return kk_ptr_box(b); +#define kk_block_unbox_as(tp,v,tag,ctx) kk_block_as(tp,kk_block_unbox(v,tag,ctx)) + +static inline kk_box_t kk_block_box(kk_block_t* b, kk_context_t* ctx) { + return kk_ptr_box(b, ctx); } -static inline kk_box_t kk_ptr_box_assert(kk_block_t* b, kk_tag_t tag) { +static inline kk_box_t kk_ptr_box_assert(kk_block_t* b, kk_tag_t tag, kk_context_t* ctx) { kk_unused_internal(tag); kk_assert_internal(kk_block_tag(b) == tag); - return kk_ptr_box(b); -} - -#define kk_basetype_unbox_as_assert(tp,b,tag) (kk_block_assert(tp,kk_ptr_unbox(b),tag)) -#define kk_basetype_unbox_as(tp,b) ((tp)kk_ptr_unbox(b)) -#define kk_basetype_box(b) (kk_ptr_box(&(b)->_block)) - -#define kk_constructor_unbox_as(tp,b,tag) (kk_basetype_unbox_as_assert(tp,b,tag)) -#define kk_constructor_box(b) (kk_basetype_box(&(b)->_base)) - -static inline kk_datatype_t kk_datatype_unbox(kk_box_t b) { - kk_datatype_t d = { b.box }; - return d; + return kk_ptr_box(b,ctx); } -static inline kk_box_t kk_datatype_box(kk_datatype_t d) { - kk_box_t b = { d.dbox }; - return b; -} -static inline kk_uintx_t kk_enum_unbox(kk_box_t b) { - return kk_uintf_unbox(b); +static inline kk_uintf_t kk_enum_unbox(kk_box_t b) { + kk_intf_t i = kk_intf_unbox(b); + kk_assert_internal(i >= 0); + return (kk_uintf_t)i; } -static inline kk_box_t kk_enum_box(kk_uintx_t u) { - return kk_uintf_box(u); +static inline kk_box_t kk_enum_box(kk_uintf_t u) { + kk_assert_internal(u <= KK_INTF_BOX_MAX(0)); + return kk_intf_box((kk_intf_t)u); } static inline kk_box_t kk_box_box(kk_box_t b, kk_context_t* ctx) { @@ -319,6 +334,12 @@ static inline kk_box_t kk_box_unbox(kk_box_t b, kk_context_t* ctx) { return b; } +// `box_any` is used to return when yielding +// (and should be accepted by any unbox operation, and also dup/drop operations. That is why we use a ptr) +static inline kk_box_t kk_box_any(kk_context_t* ctx) { + kk_datatype_ptr_dup_assert(ctx->kk_box_any, KK_TAG_BOX_ANY, ctx); + return kk_datatype_ptr_box(ctx->kk_box_any); +} /*---------------------------------------------------------------- Generic boxing of value types @@ -329,36 +350,33 @@ typedef struct kk_boxed_value_s { intptr_t data; } * kk_boxed_value_t; -#define kk_valuetype_unbox_(tp,p,x,box,ctx) \ + +kk_decl_export void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_t box, kk_borrow_t borrow, kk_context_t* ctx); + +#define kk_valuetype_unbox(tp,x,box,borrow,ctx) \ do { \ - if (kk_unlikely(kk_box_is_any(box))) { \ - p = NULL; \ - const size_t kk__max_scan_fsize = sizeof(tp)/sizeof(kk_box_t); \ - kk_box_t* _fields = (kk_box_t*)(&x); \ - for (size_t i = 0; i < kk__max_scan_fsize; i++) { _fields[i] = kk_box_any(ctx); } \ - kk_block_decref(kk_ptr_unbox(box),ctx); \ + if kk_unlikely(kk_box_is_any(box)) { \ + kk_valuetype_unbox_from_any((kk_box_t*)&x, sizeof(tp), box, borrow, ctx); \ } \ else { \ - p = kk_basetype_unbox_as_assert(kk_boxed_value_t, box, KK_TAG_BOX); \ + kk_boxed_value_t p = kk_base_type_unbox_as_assert(kk_boxed_value_t, box, KK_TAG_BOX, ctx); \ memcpy(&x,&p->data,sizeof(tp)); /* avoid aliasing warning, x = *((tp*)(&p->data)); */ \ + if (kk_is_owned(borrow)) { \ + if (kk_base_type_is_unique(p)) { kk_base_type_free(p,ctx); } \ + else { tp##_dup(x,ctx); kk_base_type_decref(p,ctx); } \ + } \ } \ } while(0) + #define kk_valuetype_box(tp,x,val,scan_fsize,ctx) \ do { \ kk_boxed_value_t p = kk_block_assert(kk_boxed_value_t, kk_block_alloc(sizeof(kk_block_t) + sizeof(tp), scan_fsize, KK_TAG_BOX, ctx), KK_TAG_BOX); \ const tp valx = val; /* ensure we can take the address */ \ memcpy(&p->data,&valx,sizeof(tp)); /* avoid aliasing warning: *((tp*)(&p->data)) = val; */ \ - x = kk_basetype_box(p); \ + x = kk_base_type_box(p,ctx); \ } while(0) -// `box_any` is used to return when yielding -// (and should be accepted by any unbox operation, and also dup/drop operations. That is why we use a ptr) -static inline kk_box_t kk_box_any(kk_context_t* ctx) { - kk_basetype_dup_assert(kk_box_any_t, ctx->kk_box_any, KK_TAG_BOX_ANY); - return kk_basetype_box(ctx->kk_box_any); -} - /*---------------------------------------------------------------- @@ -378,9 +396,9 @@ typedef struct kk_cptr_raw_s { } *kk_cptr_raw_t; kk_decl_export kk_box_t kk_cptr_raw_box(kk_free_fun_t* freefun, void* p, kk_context_t* ctx); -kk_decl_export void* kk_cptr_raw_unbox(kk_box_t b); +kk_decl_export void* kk_cptr_raw_unbox_borrowed(kk_box_t b, kk_context_t* ctx); kk_decl_export kk_box_t kk_cptr_box(void* p, kk_context_t* ctx); -kk_decl_export void* kk_cptr_unbox(kk_box_t b); +kk_decl_export void* kk_cptr_unbox_borrowed(kk_box_t b, kk_context_t* ctx); // C function pointers typedef void (*kk_cfun_ptr_t)(void); @@ -390,11 +408,32 @@ typedef struct kk_cfunptr_s { kk_cfun_ptr_t cfunptr; } *kk_cfunptr_t; -#define kk_cfun_ptr_box(f,ctx) kk_cfun_ptr_boxx((kk_cfun_ptr_t)f, ctx) -kk_decl_export kk_box_t kk_cfun_ptr_boxx(kk_cfun_ptr_t f, kk_context_t* ctx); -kk_decl_export kk_cfun_ptr_t kk_cfun_ptr_unbox(kk_box_t b); +// Koka function pointers. +// We encode these as values for efficiency. It would be best if we can assume functions addresses +// are always aligned but it turns out that this is difficult to ensure with various compilers. +// Instead we assume that the function adresses always fit an `kk_intf_t` and encode as a regular `kk_intf_t`. +// If the heap is compressed, use the offset to the main function. +static inline kk_box_t kk_kkfun_ptr_boxx(kk_cfun_ptr_t fun, kk_context_t* ctx) { // never drop; only used from function call + kk_unused(ctx); + intptr_t f = (intptr_t)fun; + #if KK_COMPRESS + f = f - (intptr_t)&kk_main_start; + #endif + kk_assert(f >= KK_INTF_BOX_MIN(0) && f <= KK_INTF_BOX_MAX(0)); + return kk_intf_box((kk_intf_t)f); +} + +#define kk_kkfun_ptr_box(fun,ctx) kk_kkfun_ptr_boxx((kk_cfun_ptr_t)fun, ctx) +static inline kk_cfun_ptr_t kk_kkfun_ptr_unbox(kk_box_t b, kk_context_t* ctx) { + kk_unused(ctx); + intptr_t f = kk_intf_unbox(b); + #if KK_COMPRESS + f = f + (intptr_t)&kk_main_start; + #endif + return (kk_cfun_ptr_t)f; +} #endif // include guard diff --git a/kklib/include/kklib/bytes.h b/kklib/include/kklib/bytes.h index f40d6c79c..d709de5f6 100644 --- a/kklib/include/kklib/bytes.h +++ b/kklib/include/kklib/bytes.h @@ -78,8 +78,8 @@ static inline void kk_bytes_drop(kk_bytes_t b, kk_context_t* ctx) { kk_datatype_drop(b, ctx); } -static inline kk_bytes_t kk_bytes_dup(kk_bytes_t b) { - return kk_datatype_dup(b); +static inline kk_bytes_t kk_bytes_dup(kk_bytes_t b, kk_context_t* ctx) { + return kk_datatype_dup(b,ctx); } @@ -117,19 +117,19 @@ static inline kk_bytes_t kk_bytes_alloc_raw_len(kk_ssize_t len, const uint8_t* p br->free = (free ? &kk_free_fun : NULL); br->cbuf = p; br->clength = len; - return kk_datatype_from_base(&br->_base); + return kk_datatype_from_base(&br->_base, ctx); } // Get access to the bytes via a pointer (and retrieve the length as well) -static inline const uint8_t* kk_bytes_buf_borrow(const kk_bytes_t b, kk_ssize_t* len) { +static inline const uint8_t* kk_bytes_buf_borrow(const kk_bytes_t b, kk_ssize_t* len, kk_context_t* ctx) { static const uint8_t empty[16] = { 0 }; if (kk_datatype_is_singleton(b)) { if (len != NULL) *len = 0; return empty; } - kk_tag_t tag = kk_datatype_tag(b); + kk_tag_t tag = kk_datatype_tag(b,ctx); if (tag == KK_TAG_BYTES_SMALL) { - const kk_bytes_small_t bs = kk_datatype_as_assert(kk_bytes_small_t, b, KK_TAG_BYTES_SMALL); + const kk_bytes_small_t bs = kk_datatype_as_assert(kk_bytes_small_t, b, KK_TAG_BYTES_SMALL, ctx); if (len != NULL) { // a small bytes of length N (<= 7) ends with an ending zero followed by (7 - N) trailing 0xFF bytes. #ifdef KK_ARCH_LITTLE_ENDIAN @@ -142,19 +142,19 @@ static inline const uint8_t* kk_bytes_buf_borrow(const kk_bytes_t b, kk_ssize_t* return &bs->u.buf[0]; } else if (tag == KK_TAG_BYTES) { - kk_bytes_normal_t bn = kk_datatype_as_assert(kk_bytes_normal_t, b, KK_TAG_BYTES); + kk_bytes_normal_t bn = kk_datatype_as_assert(kk_bytes_normal_t, b, KK_TAG_BYTES, ctx); if (len != NULL) *len = bn->length; return &bn->buf[0]; } else { - kk_bytes_raw_t br = kk_datatype_as_assert(kk_bytes_raw_t, b, KK_TAG_BYTES_RAW); + kk_bytes_raw_t br = kk_datatype_as_assert(kk_bytes_raw_t, b, KK_TAG_BYTES_RAW, ctx); if (len != NULL) *len = br->clength; return br->cbuf; } } -static inline const char* kk_bytes_cbuf_borrow(const kk_bytes_t b, kk_ssize_t* len) { - return (const char*)kk_bytes_buf_borrow(b, len); +static inline const char* kk_bytes_cbuf_borrow(const kk_bytes_t b, kk_ssize_t* len, kk_context_t* ctx) { + return (const char*)kk_bytes_buf_borrow(b, len, ctx); } @@ -163,14 +163,14 @@ static inline const char* kk_bytes_cbuf_borrow(const kk_bytes_t b, kk_ssize_t* l Length, compare --------------------------------------------------------------------------------------------------*/ -static inline kk_ssize_t kk_decl_pure kk_bytes_len_borrow(const kk_bytes_t b) { +static inline kk_ssize_t kk_decl_pure kk_bytes_len_borrow(const kk_bytes_t b, kk_context_t* ctx) { kk_ssize_t len; - kk_bytes_buf_borrow(b, &len); + kk_bytes_buf_borrow(b, &len, ctx); return len; } static inline kk_ssize_t kk_decl_pure kk_bytes_len(kk_bytes_t str, kk_context_t* ctx) { // bytes in UTF8 - kk_ssize_t len = kk_bytes_len_borrow(str); + kk_ssize_t len = kk_bytes_len_borrow(str,ctx); kk_bytes_drop(str,ctx); return len; } @@ -180,12 +180,12 @@ static inline bool kk_bytes_is_empty(kk_bytes_t s, kk_context_t* ctx) { } static inline kk_bytes_t kk_bytes_copy(kk_bytes_t b, kk_context_t* ctx) { - if (kk_datatype_is_singleton(b) || kk_datatype_is_unique(b)) { + if (kk_datatype_is_singleton(b) || kk_datatype_ptr_is_unique(b,ctx)) { return b; } else { kk_ssize_t len; - const uint8_t* buf = kk_bytes_buf_borrow(b, &len); + const uint8_t* buf = kk_bytes_buf_borrow(b, &len, ctx); kk_bytes_t bc = kk_bytes_alloc_dupn(len, buf, ctx); kk_bytes_drop(b, ctx); return bc; @@ -196,18 +196,18 @@ static inline bool kk_bytes_ptr_eq_borrow(kk_bytes_t b1, kk_bytes_t b2) { return (kk_datatype_eq(b1, b2)); } -static inline bool kk_bytes_is_empty_borrow(kk_bytes_t b) { - return (kk_bytes_len_borrow(b) == 0); +static inline bool kk_bytes_is_empty_borrow(kk_bytes_t b, kk_context_t* ctx) { + return (kk_bytes_len_borrow(b,ctx) == 0); } -kk_decl_export int kk_bytes_cmp_borrow(kk_bytes_t str1, kk_bytes_t str2); +kk_decl_export int kk_bytes_cmp_borrow(kk_bytes_t str1, kk_bytes_t str2, kk_context_t* ctx); kk_decl_export int kk_bytes_cmp(kk_bytes_t str1, kk_bytes_t str2, kk_context_t* ctx); -static inline bool kk_bytes_is_eq_borrow(kk_bytes_t s1, kk_bytes_t s2) { - return (kk_bytes_cmp_borrow(s1, s2) == 0); +static inline bool kk_bytes_is_eq_borrow(kk_bytes_t s1, kk_bytes_t s2, kk_context_t* ctx) { + return (kk_bytes_cmp_borrow(s1, s2,ctx) == 0); } -static inline bool kk_bytes_is_neq_borrow(kk_bytes_t s1, kk_bytes_t s2) { - return (kk_bytes_cmp_borrow(s1, s2) != 0); +static inline bool kk_bytes_is_neq_borrow(kk_bytes_t s1, kk_bytes_t s2, kk_context_t* ctx) { + return (kk_bytes_cmp_borrow(s1, s2, ctx) != 0); } static inline bool kk_bytes_is_eq(kk_bytes_t s1, kk_bytes_t s2, kk_context_t* ctx) { return (kk_bytes_cmp(s1, s2, ctx) == 0); @@ -237,7 +237,7 @@ static inline int kk_memcmp(const void* s, const void* t, kk_ssize_t len) { } -kk_decl_export kk_ssize_t kk_decl_pure kk_bytes_count_pattern_borrow(kk_bytes_t str, kk_bytes_t pattern); +kk_decl_export kk_ssize_t kk_decl_pure kk_bytes_count_pattern_borrow(kk_bytes_t str, kk_bytes_t pattern, kk_context_t* ctx); kk_decl_export kk_bytes_t kk_bytes_cat(kk_bytes_t s1, kk_bytes_t s2, kk_context_t* ctx); kk_decl_export kk_bytes_t kk_bytes_cat_from_buf(kk_bytes_t s1, kk_ssize_t len2, const uint8_t* buf2, kk_context_t* ctx); diff --git a/kklib/include/kklib/integer.h b/kklib/include/kklib/integer.h index 93f5dd412..858dddac8 100644 --- a/kklib/include/kklib/integer.h +++ b/kklib/include/kklib/integer.h @@ -99,8 +99,8 @@ if we added two small integers, (where bit 1 must be set after an addition): intptr_t kk_integer_add(intptr_t x, intptr_t y) { intptr_t z = x + y; - if (kk_likely((z|2) == (int32_t)z)) return (z^3); - else return kk_integer_add_generic(x,y); + if kk_likely((z|2) == (int32_t)z) return (z^3); + else return kk_integer_add_generic(x,y); } Now we have just one test that test both for overflow, as well as for the @@ -148,98 +148,107 @@ to indicate the portable SOFA technique is about 5% (x64) to 10% (M1) faster. -- Daan Leijen, 2020-2022. --------------------------------------------------------------------------------------------------*/ -#if !defined(KK_USE_BUILTIN_OVF) -#define KK_USE_BUILTIN_OVF (0) // portable overflow detection seems always faster +// Integer arithmetic method +// note: we support these for now for experimentation, but we plan to converge on a single method +// in the future in order to simplify the code. +#define KK_INT_USE_OVF 1 // use limited tag bits and architecture overflow detection (only with gcc/clang) +#define KK_INT_USE_TAGOVF 2 // use tag bits (upfront check) and architecture overflow detection (only with gcc/clang) +#define KK_INT_USE_SOFA 3 // use sign extended overflow arithmetic with limited tag bits + +#ifndef KK_INT_ARITHMETIC +#if defined(__GNUC__) // (KK_INTF_SIZE <= 4) +#define KK_INT_ARITHMETIC KK_INT_USE_OVF +#else +#define KK_INT_ARITHMETIC KK_INT_USE_SOFA +#endif #endif -#if KK_USE_BUILTIN_OVF +#if KK_INT_ARITHMETIC == KK_INT_USE_OVF || KK_INT_ARITHMETIC == KK_INT_USE_TAGOVF typedef kk_intf_t kk_smallint_t; -#define KK_SMALLINT_BITS (KK_INTF_BITS) +#define KK_SMALLINT_BITS (KK_INTF_BOX_BITS(1)) +#define KK_SMALLINT_MAX (KK_INTF_BOX_MAX(1)) #elif KK_INTF_SIZE>=16 typedef int64_t kk_smallint_t; #define KK_SMALLINT_BITS (64) +#define KK_SMALLINT_MAX (INT64_MAX) #elif KK_INTF_SIZE==8 typedef int32_t kk_smallint_t; #define KK_SMALLINT_BITS (32) +#define KK_SMALLINT_MAX (INT32_MAX) #elif KK_INTF_SIZE==4 typedef int16_t kk_smallint_t; #define KK_SMALLINT_BITS (16) +#define KK_SMALLINT_MAX (INT16_MAX) #elif KK_INTF_SIZE==2 typedef int8_t kk_smallint_t; #define KK_SMALLINT_BITS (8) +#define KK_SMALLINT_MAX (INT8_MAX) #else # error "platform must be 16, 32, 64, or 128 bits." #endif -#define KK_SMALLINT_SIZE (KK_SMALLINT_BITS/8) -#define KK_SMALLINT_MAX (KK_INTF_MAX >> (KK_INTF_BITS - KK_SMALLINT_BITS + 2)) -#define KK_SMALLINT_MIN (-KK_SMALLINT_MAX - 1) - -static inline kk_intf_t _kk_integer_value(kk_integer_t i) { - return (kk_intf_t)i.ibox; // potentially cast to smaller kk_intf_t (as on arm CHERI) -} +#define KK_SMALLINT_SIZE (KK_SMALLINT_BITS/8) +#define KK_SMALLINT_MIN (-KK_SMALLINT_MAX - 1) static inline bool kk_is_smallint(kk_integer_t i) { - return ((_kk_integer_value(i)&1) != 0); + return kk_is_value(i.ibox); } static inline bool kk_is_bigint(kk_integer_t i) { - return ((_kk_integer_value(i)&1) == 0); + return kk_is_ptr(i.ibox); } -static inline kk_ptr_t _kk_integer_ptr(kk_integer_t i) { +static inline kk_ptr_t _kk_integer_ptr(kk_integer_t i, kk_context_t* ctx) { kk_assert_internal(kk_is_bigint(i)); - return (kk_ptr_t)(i.ibox); -} - -static inline kk_integer_t _kk_new_integer(kk_intf_t i) { - kk_integer_t z = { (uintptr_t)i }; // todo: optimize in case sizeof(kk_intf_t) < sizeof(intptr_t) ? - return z; + return kk_ptr_decode(i.ibox,ctx); } static inline kk_intf_t kk_smallint_from_integer(kk_integer_t i) { // use for known small ints - kk_assert_internal(kk_is_smallint(i) && (_kk_integer_value(i)&3)==1); - return kk_sarf(_kk_integer_value(i),2); + kk_assert_internal(kk_is_smallint(i)); + return kk_intf_decode(i.ibox,1); } static inline kk_integer_t kk_integer_from_small(kk_intf_t i) { // use for known small int constants (at most 14 bits) kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); - return _kk_new_integer(kk_shlf(i,2)|1); + kk_integer_t z = { kk_intf_encode(i,1) }; + return z; } static inline bool kk_is_integer(kk_integer_t i) { return ((kk_is_smallint(i) && kk_smallint_from_integer(i) >= KK_SMALLINT_MIN && kk_smallint_from_integer(i) <= KK_SMALLINT_MAX) - || (kk_is_bigint(i) && kk_block_tag(_kk_integer_ptr(i)) == KK_TAG_BIGINT)); + || (kk_is_bigint(i) && kk_block_tag(_kk_integer_ptr(i,kk_get_context())) == KK_TAG_BIGINT)); } static inline bool kk_are_smallints(kk_integer_t i, kk_integer_t j) { kk_assert_internal(kk_is_integer(i) && kk_is_integer(j)); - return (((_kk_integer_value(i)&_kk_integer_value(j))&1) == 1); - //return ((_kk_integer_value(i)&1)==1 || (_kk_integer_value(j)&1)==1); + #if KK_TAG_VALUE == 1 + return kk_is_value(i.ibox & j.ibox); + #else + return (kk_is_smallint(i) && kk_is_smallint(j)); + #endif } static inline bool kk_integer_small_eq(kk_integer_t x, kk_integer_t y) { kk_assert_internal(kk_are_smallints(x, y)); - return (_kk_integer_value(x) == _kk_integer_value(y)); + return (x.ibox == y.ibox); } - #define kk_integer_zero (kk_integer_from_small(0)) #define kk_integer_one (kk_integer_from_small(1)) #define kk_integer_min_one (kk_integer_from_small(-1)) static inline bool kk_integer_is_zero_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_zero)); + if kk_likely(kk_is_smallint(x)) return kk_integer_small_eq(x,kk_integer_zero); return false; } static inline bool kk_integer_is_one_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_one)); + if kk_likely(kk_is_smallint(x)) return kk_integer_small_eq(x, kk_integer_one); return false; } static inline bool kk_integer_is_minus_one_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(kk_integer_min_one)); + if kk_likely(kk_is_smallint(x)) return kk_integer_small_eq(x, kk_integer_min_one); return false; } @@ -248,24 +257,27 @@ static inline bool kk_integer_is_minus_one_borrow(kk_integer_t x) { -----------------------------------------------------------------------------------*/ // Isomorphic with boxed values -static inline kk_box_t kk_integer_box(kk_integer_t i) { +static inline kk_box_t kk_integer_box(kk_integer_t i, kk_context_t* ctx) { + kk_unused(ctx); kk_box_t b = { i.ibox }; return b; } -static inline kk_integer_t kk_integer_unbox(kk_box_t b) { +static inline kk_integer_t kk_integer_unbox(kk_box_t b, kk_context_t* ctx) { + kk_unused(ctx); kk_integer_t i = { b.box }; return i; } -static inline kk_integer_t kk_integer_dup(kk_integer_t i) { - if (kk_unlikely(kk_is_bigint(i))) { kk_block_dup(_kk_integer_ptr(i)); } +static inline kk_integer_t kk_integer_dup(kk_integer_t i, kk_context_t* ctx) { + if kk_unlikely(kk_is_bigint(i)) { kk_block_dup(_kk_integer_ptr(i,ctx)); } return i; } -static inline void kk_integer_drop(kk_integer_t i, kk_context_t* ctx) { - if (kk_unlikely(kk_is_bigint(i))) { kk_block_drop(_kk_integer_ptr(i), ctx); } +static inline void kk_integer_drop(kk_integer_t i, kk_context_t* ctx) { + if kk_unlikely(kk_is_bigint(i)) { kk_block_drop(_kk_integer_ptr(i,ctx), ctx); } } + kk_decl_export bool kk_integer_parse(const char* num, kk_integer_t* result, kk_context_t* ctx); kk_decl_export bool kk_integer_hex_parse(const char* s, kk_integer_t* res, kk_context_t* ctx); kk_decl_export kk_integer_t kk_integer_from_str(const char* num, kk_context_t* ctx); // for known correct string number (returns 0 on wrong string) @@ -299,7 +311,7 @@ kk_decl_export kk_decl_noinline kk_integer_t kk_integer_sqr_generic(kk_integer_ kk_decl_export kk_decl_noinline kk_integer_t kk_integer_pow(kk_integer_t x, kk_integer_t p, kk_context_t* ctx); kk_decl_export kk_decl_noinline bool kk_integer_is_even_generic(kk_integer_t x, kk_context_t* ctx); -kk_decl_export kk_decl_noinline int kk_integer_signum_generic_bigint(kk_integer_t x); +kk_decl_export kk_decl_noinline int kk_integer_signum_generic_bigint(kk_integer_t x, kk_context_t* ctx); kk_decl_export kk_decl_noinline kk_integer_t kk_integer_ctz(kk_integer_t x, kk_context_t* ctx); // count trailing zero digits kk_decl_export kk_decl_noinline kk_integer_t kk_integer_count_digits(kk_integer_t x, kk_context_t* ctx); // count decimal digits @@ -318,9 +330,10 @@ kk_decl_export double kk_double_round_even(double d, kk_context_t* ctx); static inline kk_integer_t kk_integer_from_uint8(uint8_t u, kk_context_t* ctx) { #if (KK_SMALLINT_MAX >= UINT8_MAX) + kk_unused(ctx); return kk_integer_from_small((kk_intf_t)u); #else - return (kk_likely(u <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)u) : kk_integer_from_big(u, ctx)); + return kk_likely(u <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)u) : kk_integer_from_big(u, ctx); #endif } @@ -329,7 +342,7 @@ static inline kk_integer_t kk_integer_from_int8(int8_t i, kk_context_t* ctx) { kk_unused(ctx); return kk_integer_from_small(i); #else - return (kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx)); + return kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx); #endif } @@ -338,7 +351,7 @@ static inline kk_integer_t kk_integer_from_int16(int16_t i, kk_context_t* ctx) { kk_unused(ctx); return kk_integer_from_small(i); #else - return (kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx)); + return kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx); #endif } @@ -347,28 +360,29 @@ static inline kk_integer_t kk_integer_from_int32(int32_t i, kk_context_t* ctx) { kk_unused(ctx); return kk_integer_from_small(i); #else - return (kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx)); + return kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small(i) : kk_integer_from_big(i, ctx); #endif } static inline kk_integer_t kk_integer_from_uint32(uint32_t u, kk_context_t* ctx) { #if (KK_SMALLINT_MAX >= UINT32_MAX) + kk_unused(ctx); return kk_integer_from_small((kk_intf_t)u); #else - return (kk_likely(u <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)u) : kk_integer_from_big(u, ctx)); + return kk_likely(u <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)u) : kk_integer_from_big(u, ctx); #endif } static inline kk_integer_t kk_integer_from_int64(int64_t i, kk_context_t* ctx) { - return (kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_big64(i, ctx)); + return kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_big64(i, ctx); } static inline kk_integer_t kk_integer_from_uint64(uint64_t i, kk_context_t* ctx) { - return (kk_likely(i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_bigu64(i, ctx)); + return kk_likely(i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_bigu64(i, ctx); } static inline kk_integer_t kk_integer_from_int(kk_intx_t i, kk_context_t* ctx) { - return (kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_big(i, ctx)); + return kk_likely(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX) ? kk_integer_from_small((kk_intf_t)i) : kk_integer_from_big(i, ctx); } @@ -449,12 +463,27 @@ Multiply: Since `boxed(n) = n*4 + 1`, we can multiply as: we check before multiply for small integers and do not combine with the overflow check. -----------------------------------------------------------------------------------*/ -#if KK_USE_BUILTIN_OVF +static kk_intf_t _kk_integer_value(kk_integer_t i) { + #if KK_INT_ARITHMETIC == KK_INT_USE_TAGOVF + kk_assert_internal(kk_is_smallint(i)); + #endif + return (kk_intf_t)i.ibox; +} + +static kk_integer_t _kk_new_integer(kk_intf_t i) { + kk_integer_t z = { i }; + kk_assert_internal(kk_is_smallint(z)); + return z; +} + +#if (KK_INT_ARITHMETIC == KK_INT_USE_OVF) && (KK_TAG_VALUE==1) static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_assert_internal((_kk_integer_value(x) & 2) == 0); + kk_assert_internal((_kk_integer_value(y) & 2) == 0); kk_intf_t z; - if (kk_unlikely(__builtin_add_overflow(_kk_integer_value(x), _kk_integer_value(y), &z) || (z&2)==0)) { - return kk_integer_add_generic(x,y,ctx); + if kk_unlikely(__builtin_add_overflow(_kk_integer_value(x), _kk_integer_value(y), &z) || (z&2)==0) { + return kk_integer_add_generic(x,y,ctx); } kk_assert_internal((z&3) == 2); return _kk_new_integer(z^3); @@ -463,7 +492,7 @@ static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); kk_intf_t z; - if (kk_unlikely(kk_is_bigint(x) || __builtin_add_overflow(_kk_integer_value(x), kk_shlf(i,2), &z))) { + if kk_unlikely(kk_is_bigint(x) || __builtin_add_overflow(_kk_integer_value(x), kk_shlf(i,2), &z)) { return kk_integer_add_generic(x,kk_integer_from_small(i),ctx); } kk_assert_internal((z&3) == 1); @@ -472,7 +501,7 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z; - if (kk_unlikely(__builtin_sub_overflow(_kk_integer_value(x)^3, _kk_integer_value(y), &z) || (z&2)!=0)) { + if kk_unlikely(__builtin_sub_overflow(_kk_integer_value(x)^3, _kk_integer_value(y), &z) || (z&2)!=0) { return kk_integer_sub_generic(x,y,ctx); } kk_assert_internal((z&3) == 1); @@ -484,27 +513,71 @@ static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_intf_t i = kk_sar(_kk_integer_value(x), 1); kk_intf_t j = kk_sar(_kk_integer_value(y), 1); kk_intf_t z; - if (kk_unlikely(__builtin_mul_overflow(i, j, &z))) { + if kk_unlikely(__builtin_mul_overflow(i, j, &z)) { return kk_integer_mul_generic(x, y, ctx); } kk_assert_internal((z&3)==0); return _kk_new_integer(z|1); } -#else // use SOFA +#elif (KK_INT_ARITHMETIC == KK_INT_USE_TAGOVF) && (KK_TAG_VALUE==1) // test for small ints upfront + +static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_intf_t z; + if kk_unlikely(!kk_are_smallints(x, y) || __builtin_add_overflow(_kk_integer_value(x), _kk_integer_value(y), &z)) { + return kk_integer_add_generic(x, y, ctx); + } + kk_assert_internal((z & 3) == 2); + return _kk_new_integer(z ^ 3); +} + +static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { + kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); + kk_intf_t z; + if kk_unlikely(kk_is_bigint(x) || __builtin_add_overflow(_kk_integer_value(x), kk_shlf(i, 2), &z)) { + return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); + } + kk_assert_internal((z & 3) == 1); + return _kk_new_integer(z); +} + +static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_intf_t z; + if kk_unlikely(!kk_are_smallints(x, y) || __builtin_sub_overflow(_kk_integer_value(x) ^ 3, _kk_integer_value(y), &z)) { + return kk_integer_sub_generic(x, y, ctx); + } + kk_assert_internal((z & 3) == 1); + return _kk_new_integer(z); +} + +static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_assert_internal(kk_are_smallints(x, y)); + kk_intf_t i = kk_sar(_kk_integer_value(x), 1); + kk_intf_t j = kk_sar(_kk_integer_value(y), 1); + kk_intf_t z; + if kk_unlikely(__builtin_mul_overflow(i, j, &z)) { + return kk_integer_mul_generic(x, y, ctx); + } + kk_assert_internal((z & 3) == 0); + return _kk_new_integer(z | 1); +} + +#elif (KK_INT_ARITHMETIC == KK_INT_USE_SOFA) // we can either mask on the left side or on the sign extended right side. // it turns out that this affects the quality of the generated instructions and we pick depending on the platform -#if defined(__x86_64__) || defined(__i386__) || defined(_M_IX86) || defined(_M_X64) -#define KK_SOFA_MASK_RIGHT /* only on x86 and x64 is masking on the sign-extended right side better */ +#if defined(__clang__) && (defined(__x86_64__) || defined(__i386__) || defined(_M_IX86) || defined(_M_X64)) +#define KK_INT_SOFA_RIGHT_BIAS /* only on x86 and x64 is masking on the sign-extended right side better */ #endif +#if (KK_TAG_VALUE == 1) + static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); - #ifndef KK_SOFA_MASK_RIGHT - if (kk_likely((z|2) == (kk_smallint_t)z)) // set bit 1 and compare sign extension + #ifndef KK_INT_SOFA_RIGHT_BIAS + if kk_likely((z|2) == (kk_smallint_t)z) // set bit 1 and compare sign extension #else - if (kk_likely(z == ((kk_smallint_t)z|2))) + if kk_likely(z == ((kk_smallint_t)z|2)) #endif { kk_assert_internal((z&3) == 2); @@ -516,10 +589,10 @@ static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); kk_intf_t z = _kk_integer_value(x) + kk_shlf(i,2); - #ifndef KK_SOFA_MASK_RIGHT - if (kk_likely((z|1) == (kk_smallint_t)z)) + #ifndef KK_INT_SOFA_RIGHT_BIAS + if kk_likely((z|1) == (kk_smallint_t)z) #else - if (kk_likely(z == ((kk_smallint_t)z|1))) + if kk_likely(z == ((kk_smallint_t)z|1)) #endif { kk_assert_internal((z&3) == 1); @@ -531,10 +604,10 @@ static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_intf_t z = (_kk_integer_value(x)^3) - _kk_integer_value(y); - #ifndef KK_SOFA_MASK_RIGHT - if (kk_likely((z&~2) == (kk_smallint_t)z)) // clear bit 1 and compare sign extension + #ifndef KK_INT_SOFA_RIGHT_BIAS + if kk_likely((z&~2) == (kk_smallint_t)z) // clear bit 1 and compare sign extension #else - if (kk_likely(z == ((kk_smallint_t)z&~2))) + if kk_likely(z == ((kk_smallint_t)z&~2)) #endif { kk_assert_internal((z&3) == 1); @@ -543,23 +616,72 @@ static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_con return kk_integer_sub_generic(x, y, ctx); } +#else // KK_INT_TAG == 0 + +static inline kk_integer_t kk_integer_add(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_intf_t z = _kk_integer_value(x) + _kk_integer_value(y); + #ifndef KK_INT_SOFA_RIGHT_BIAS + if kk_likely((z&~3) == (kk_smallint_t)z) // clear lower 2 bits and compare sign extension + #else + if kk_likely(z == ((kk_smallint_t)z&~3)) + #endif + { + kk_assert_internal((z&3) == 0); + return _kk_new_integer(z); + } + return kk_integer_add_generic(x, y, ctx); +} + +static inline kk_integer_t kk_integer_add_small_const(kk_integer_t x, kk_intf_t i, kk_context_t* ctx) { + kk_assert_internal(i >= KK_SMALLINT_MIN && i <= KK_SMALLINT_MAX); + kk_intf_t z = _kk_integer_value(x) + kk_shlf(i,2); + #ifndef KK_INT_SOFA_RIGHT_BIAS + if kk_likely((z&~3) == (kk_smallint_t)z) + #else + if kk_likely(z == ((kk_smallint_t)z&~3)) + #endif + { + kk_assert_internal((z&3) == 0); + return _kk_new_integer(z); + } + return kk_integer_add_generic(x, kk_integer_from_small(i), ctx); +} + +static inline kk_integer_t kk_integer_sub(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + kk_intf_t z = _kk_integer_value(x) - (_kk_integer_value(y)^3) + 3; + #ifndef KK_INT_SOFA_RIGHT_BIAS + if kk_likely((z&~3) == (kk_smallint_t)z) // clear lower 2 bits and compare sign extension + #else + if kk_likely(z == ((kk_smallint_t)z&~3)) + #endif + { + kk_assert_internal((z&3) == 0); + return _kk_new_integer(z); + } + return kk_integer_sub_generic(x, y, ctx); +} + +#endif // KK_TAG_VALUE == 1 or 0 static inline kk_integer_t kk_integer_mul_small(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_assert_internal(kk_are_smallints(x, y)); - kk_intf_t i = kk_sar(_kk_integer_value(x), 1); - kk_intf_t j = kk_sar(_kk_integer_value(y), 1); + kk_intf_t i = kk_sarf(_kk_integer_value(x), 1); + kk_intf_t j = kk_sarf(_kk_integer_value(y), 1); kk_intf_t z = i*j; - if (kk_likely(z == (kk_smallint_t)(z))) { + if kk_likely(z == (kk_smallint_t)(z)) { kk_assert_internal((z&3) == 0); - return _kk_new_integer(z|1); + return _kk_new_integer(z|KK_TAG_VALUE); } return kk_integer_mul_generic(x, y, ctx); } +#else +#error "Define fast arithmetic primitives for this platform" #endif + static inline kk_integer_t kk_integer_mul(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return kk_integer_mul_small(x, y, ctx); + if kk_likely(kk_are_smallints(x, y)) return kk_integer_mul_small(x, y, ctx); return kk_integer_mul_generic(x, y, ctx); } @@ -573,8 +695,8 @@ static inline kk_integer_t kk_integer_mul(kk_integer_t x, kk_integer_t y, kk_con static inline kk_integer_t kk_integer_cdiv_small(kk_integer_t x, kk_integer_t y) { kk_assert_internal(kk_are_smallints(x, y)); kk_assert_internal(!kk_integer_is_zero_borrow(y)); - kk_intf_t i = kk_sar(_kk_integer_value(x), 1); - kk_intf_t j = kk_sar(_kk_integer_value(y), 1); + kk_intf_t i = kk_smallint_from_integer(x); + kk_intf_t j = kk_smallint_from_integer(y); return kk_integer_from_small(i/j); } @@ -663,39 +785,39 @@ static inline bool kk_are_small_div_ints(kk_integer_t x, kk_integer_t y) { } static inline kk_integer_t kk_integer_cdiv(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_cdiv_small(x, y); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_cdiv_small(x, y); return kk_integer_cdiv_generic(x, y, ctx); } static inline kk_integer_t kk_integer_cmod(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_cmod_small(x, y); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_cmod_small(x, y); return kk_integer_cmod_generic(x, y, ctx); } static inline kk_integer_t kk_integer_cdiv_cmod(kk_integer_t x, kk_integer_t y, kk_integer_t* mod, kk_context_t* ctx) { kk_assert_internal(mod!=NULL); - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_cdiv_cmod_small(x, y, mod); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_cdiv_cmod_small(x, y, mod); return kk_integer_cdiv_cmod_generic(x, y, mod, ctx); } static inline kk_integer_t kk_integer_div(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_div_small(x, y); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_div_small(x, y); return kk_integer_div_generic(x, y, ctx); } static inline kk_integer_t kk_integer_mod(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_mod_small(x, y); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_mod_small(x, y); return kk_integer_mod_generic(x, y, ctx); } static inline kk_integer_t kk_integer_div_mod(kk_integer_t x, kk_integer_t y, kk_integer_t* mod, kk_context_t* ctx) { kk_assert_internal(mod!=NULL); - if (kk_likely(kk_are_small_div_ints(x, y))) return kk_integer_div_mod_small(x, y, mod); + if kk_likely(kk_are_small_div_ints(x, y)) return kk_integer_div_mod_small(x, y, mod); return kk_integer_div_mod_generic(x, y, mod, ctx); } static inline kk_integer_t kk_integer_sqr(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return kk_integer_mul_small(x, x, ctx); + if kk_likely(kk_is_smallint(x)) return kk_integer_mul_small(x, x, ctx); return kk_integer_sqr_generic(x, ctx); } @@ -720,101 +842,97 @@ static inline kk_integer_t kk_integer_neg_small(kk_integer_t x, kk_context_t* ct } static inline kk_integer_t kk_integer_neg(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return kk_integer_neg_small(x, ctx); + if kk_likely(kk_is_smallint(x)) return kk_integer_neg_small(x, ctx); return kk_integer_neg_generic(x, ctx); } static inline kk_integer_t kk_integer_abs(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) < 0 ? kk_integer_neg_small(x, ctx) : x); - return (kk_integer_signum_generic_bigint(x) < 0 ? kk_integer_neg_generic(x, ctx) : x); + if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) < 0 ? kk_integer_neg_small(x, ctx) : x); + return (kk_integer_signum_generic_bigint(x,ctx) < 0 ? kk_integer_neg_generic(x, ctx) : x); } static inline int kk_integer_cmp_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) == _kk_integer_value(y) ? 0 : (_kk_integer_value(x) > _kk_integer_value(y) ? 1 : -1)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) == _kk_integer_value(y) ? 0 : (_kk_integer_value(x) > _kk_integer_value(y) ? 1 : -1)); return kk_integer_cmp_generic_borrow(x, y, ctx); } static inline bool kk_integer_lt_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) < _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) < _kk_integer_value(y)); return (kk_integer_cmp_generic_borrow(x, y, ctx) == -1); } static inline bool kk_integer_lt(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) < _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) < _kk_integer_value(y)); return (kk_integer_cmp_generic(x, y, ctx) == -1); } static inline bool kk_integer_lte_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) <= _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) <= _kk_integer_value(y)); return (kk_integer_cmp_generic_borrow(x, y, ctx) <= 0); } static inline bool kk_integer_gt_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) > _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) > _kk_integer_value(y)); return (kk_integer_cmp_generic_borrow(x, y, ctx) == 1); } static inline bool kk_integer_gt(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) > _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) > _kk_integer_value(y)); return (kk_integer_cmp_generic(x, y, ctx) == 1); } static inline bool kk_integer_gte_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) >= _kk_integer_value(y)); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x) >= _kk_integer_value(y)); return (kk_integer_cmp_generic_borrow(x, y, ctx) >= 0); } static inline bool kk_integer_eq_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small - // if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) == _kk_integer_value(y)); + if (_kk_integer_value(x) == _kk_integer_value(y)) return true; + if kk_likely(kk_is_smallint(x)) return false; return (kk_integer_cmp_generic_borrow(x, y, ctx) == 0); } static inline bool kk_integer_eq(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) == _kk_integer_value(y)); // assume bigint is never small - // if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x) == _kk_integer_value(y)); + if (_kk_integer_value(x) == _kk_integer_value(y)) return true; + if kk_likely(kk_is_smallint(x)) return false; return (kk_integer_cmp_generic(x, y, ctx) == 0); } static inline bool kk_integer_neq_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) != _kk_integer_value(y)); // assume bigint is never small - // if (kk_are_smallints(x,y)) return (_kk_integer_value(x) != _kk_integer_value(y)); - return (kk_integer_cmp_generic_borrow(x, y, ctx) != 0); + return !kk_integer_eq_borrow(x,y,ctx); } static inline bool kk_integer_neq(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) != _kk_integer_value(y)); // assume bigint is never small - // if (kk_are_smallints(x,y)) return (_kk_integer_value(x) != _kk_integer_value(y)); - return (kk_integer_cmp_generic(x, y, ctx) != 0); + return !kk_integer_eq(x,y,ctx); } static inline bool kk_integer_is_even(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return ((_kk_integer_value(x)&0x04)==0); + if kk_likely(kk_is_smallint(x)) return ((_kk_integer_value(x)&0x04)==0); return kk_integer_is_even_generic(x, ctx); } static inline bool kk_integer_is_odd(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return ((_kk_integer_value(x)&0x04)!=0); + if kk_likely(kk_is_smallint(x)) return ((_kk_integer_value(x)&0x04)!=0); return !kk_integer_is_even_generic(x, ctx); } -static inline int kk_integer_signum_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return ((_kk_integer_value(x)>_kk_integer_value(kk_integer_zero)) - (_kk_integer_value(x)<0)); - return kk_integer_signum_generic_bigint(x); +static inline int kk_integer_signum_borrow(kk_integer_t x, kk_context_t* ctx) { + if kk_likely(kk_is_smallint(x)) return ((_kk_integer_value(x)>_kk_integer_value(kk_integer_zero)) - (_kk_integer_value(x)<0)); + return kk_integer_signum_generic_bigint(x,ctx); } -static inline bool kk_integer_is_pos_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x) > _kk_integer_value(kk_integer_zero)); - return (kk_integer_signum_generic_bigint(x) > 0); +static inline bool kk_integer_is_pos_borrow(kk_integer_t x, kk_context_t* ctx) { + if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x) > _kk_integer_value(kk_integer_zero)); + return (kk_integer_signum_generic_bigint(x,ctx) > 0); } -static inline bool kk_integer_is_neg_borrow(kk_integer_t x) { - if (kk_likely(kk_is_smallint(x))) return (_kk_integer_value(x)<0); - return (kk_integer_signum_generic_bigint(x) < 0); +static inline bool kk_integer_is_neg_borrow(kk_integer_t x, kk_context_t* ctx) { + if kk_likely(kk_is_smallint(x)) return (_kk_integer_value(x)<0); + return (kk_integer_signum_generic_bigint(x,ctx) < 0); } static inline kk_integer_t kk_integer_max(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x)>=_kk_integer_value(y) ? x : y); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x)>=_kk_integer_value(y) ? x : y); if (kk_integer_gte_borrow(x, y, ctx)) { kk_integer_drop(y, ctx); return x; } @@ -824,7 +942,7 @@ static inline kk_integer_t kk_integer_max(kk_integer_t x, kk_integer_t y, kk_con } static inline kk_integer_t kk_integer_min(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - if (kk_likely(kk_are_smallints(x, y))) return (_kk_integer_value(x)<=_kk_integer_value(y) ? x : y); + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x)<=_kk_integer_value(y) ? x : y); if (kk_integer_lte_borrow(x, y, ctx)) { kk_integer_drop(y, ctx); return x; } @@ -833,19 +951,28 @@ static inline kk_integer_t kk_integer_min(kk_integer_t x, kk_integer_t y, kk_con } } +static inline kk_integer_t kk_integer_min_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { + if kk_likely(kk_are_smallints(x, y)) return (_kk_integer_value(x)<=_kk_integer_value(y) ? x : y); + if (kk_integer_lte_borrow(x, y, ctx)) { + return kk_integer_dup(x,ctx); + } + else { + return kk_integer_dup(y,ctx); + } +} /*--------------------------------------------------------------------------------- clamp int to smaller ints ---------------------------------------------------------------------------------*/ static inline int32_t kk_integer_clamp32(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); -#if (KK_SMALLINT_MAX > INT32_MAX) + #if (KK_SMALLINT_MAX > INT32_MAX) return (i < INT32_MIN ? INT32_MIN : (i > INT32_MAX ? INT32_MAX : (int32_t)i)); -#else + #else return (int32_t)i; -#endif + #endif } else { return kk_integer_clamp32_generic(x,ctx); @@ -853,27 +980,27 @@ static inline int32_t kk_integer_clamp32(kk_integer_t x, kk_context_t* ctx) { } static inline int32_t kk_integer_clamp32_borrow(kk_integer_t x, kk_context_t* ctx) { // used for cfc field of evidence - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); -#if (KK_SMALLINT_MAX > INT32_MAX) + #if (KK_SMALLINT_MAX > INT32_MAX) return (i < INT32_MIN ? INT32_MIN : (i > INT32_MAX ? INT32_MAX : (int32_t)i)); -#else + #else return (int32_t)i; -#endif + #endif } else { - return kk_integer_clamp32_generic(kk_integer_dup(x), ctx); + return kk_integer_clamp32_generic(kk_integer_dup(x,ctx), ctx); } } static inline int64_t kk_integer_clamp64(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); -#if (KK_SMALLINT_MAX > INT64_MAX) + #if (KK_SMALLINT_MAX > INT64_MAX) return (i < INT64_MIN ? INT64_MIN : (i > INT64_MAX ? INT64_MAX : (int64_t)i)); -#else + #else return (int64_t)i; -#endif + #endif } else { return kk_integer_clamp64_generic(x, ctx); @@ -881,16 +1008,16 @@ static inline int64_t kk_integer_clamp64(kk_integer_t x, kk_context_t* ctx) { } static inline int64_t kk_integer_clamp64_borrow(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); -#if (KK_SMALLINT_MAX > INT64_MAX) + #if (KK_SMALLINT_MAX > INT64_MAX) return (i < INT64_MIN ? INT64_MIN : (i > INT64_MAX ? INT64_MAX : (int64_t)i)); -#else + #else return (int64_t)i; -#endif + #endif } else { - return kk_integer_clamp64_generic(kk_integer_dup(x), ctx); + return kk_integer_clamp64_generic(kk_integer_dup(x,ctx), ctx); } } @@ -910,69 +1037,69 @@ static inline int16_t kk_integer_clamp_int16(kk_integer_t x, kk_context_t* ctx) } static inline size_t kk_integer_clamp_size_t(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) { + if kk_likely(kk_is_smallint(x)) { kk_intf_t i = kk_smallint_from_integer(x); -#if (KK_SMALLINT_MAX > SIZE_MAX) + #if (KK_SMALLINT_MAX > SIZE_MAX) return (i < 0 ? 0 : (i > SIZE_MAX ? SIZE_MAX : (size_t)i)); -#else + #else return (i < 0 ? 0 : (size_t)i); -#endif + #endif } return kk_integer_clamp_size_t_generic(x,ctx); } static inline kk_ssize_t kk_integer_clamp_ssize_t(kk_integer_t x, kk_context_t* ctx) { -#if KK_SSIZE_MAX == INT32_MAX + #if KK_SSIZE_MAX == INT32_MAX return kk_integer_clamp32(x,ctx); -#elif KK_SSIZE_MAX == INT64_MAX + #elif KK_SSIZE_MAX == INT64_MAX return kk_integer_clamp64(x,ctx); -#else -#error "define integer_clamp_ssize_t on this platform" -#endif + #else + #error "define integer_clamp_ssize_t on this platform" + #endif } static inline kk_ssize_t kk_integer_clamp_ssize_t_borrow(kk_integer_t x, kk_context_t* ctx) { // used for array indexing -#if KK_SSIZE_MAX == INT32_MAX + #if KK_SSIZE_MAX == INT32_MAX return kk_integer_clamp32_borrow(x, ctx); -#elif KK_SSIZE_MAX == INT64_MAX + #elif KK_SSIZE_MAX == INT64_MAX return kk_integer_clamp64_borrow(x, ctx); -#else -#error "define integer_clamp_ssize_t_borrow on this platform" -#endif + #else + #error "define integer_clamp_ssize_t_borrow on this platform" + #endif } static inline intptr_t kk_integer_clamp_intptr_t(kk_integer_t x, kk_context_t* ctx) { -#if INTPTR_MAX == INT32_MAX + #if INTPTR_MAX == INT32_MAX return kk_integer_clamp32(x,ctx); -#elif INTPTR_MAX == INT64_MAX + #elif INTPTR_MAX == INT64_MAX return kk_integer_clamp64(x,ctx); -#else -#error "define integer_clamp_intptr_t on this platform" -#endif + #else + #error "define integer_clamp_intptr_t on this platform" + #endif } static inline kk_intx_t kk_integer_clamp(kk_integer_t x, kk_context_t* ctx) { -#if KK_INTX_MAX == INT32_MAX + #if KK_INTX_MAX == INT32_MAX return kk_integer_clamp32(x, ctx); -#elif KK_INTX_MAX == INT64_MAX + #elif KK_INTX_MAX == INT64_MAX return kk_integer_clamp64(x, ctx); -#else -#error "define integer_clamp on this platform" -#endif + #else + #error "define integer_clamp on this platform" + #endif } static inline kk_intx_t kk_integer_clamp_borrow(kk_integer_t x, kk_context_t* ctx) { -#if KK_INTX_MAX == INT32_MAX + #if KK_INTX_MAX == INT32_MAX return kk_integer_clamp32_borrow(x, ctx); -#elif KK_INTX_MAX == INT64_MAX + #elif KK_INTX_MAX == INT64_MAX return kk_integer_clamp64_borrow(x, ctx); -#else -#error "define integer_clamp_borrow on this platform" -#endif + #else + #error "define integer_clamp_borrow on this platform" + #endif } static inline double kk_integer_as_double(kk_integer_t x, kk_context_t* ctx) { - if (kk_likely(kk_is_smallint(x))) return (double)(kk_smallint_from_integer(x)); + if kk_likely(kk_is_smallint(x)) return (double)(kk_smallint_from_integer(x)); return kk_integer_as_double_generic(x,ctx); } diff --git a/kklib/include/kklib/maybe.h b/kklib/include/kklib/maybe.h new file mode 100644 index 000000000..a10fd325c --- /dev/null +++ b/kklib/include/kklib/maybe.h @@ -0,0 +1,87 @@ +#pragma once +#ifndef KK_MAYBE_H +#define KK_MAYBE_H +/*--------------------------------------------------------------------------- + Copyright 2020-2022, Microsoft Research, Daan Leijen. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the LICENSE file at the root of this distribution. +---------------------------------------------------------------------------*/ + +/*-------------------------------------------------------------------------------------- + Optimized support for maybe like datatypes. + We try to avoid allocating for maybe-like types. First we define maybe as a value + type (in std/core/types) and thus a Just is usually passed in 2 registers for the tag + and payload. This does not help though if it becomes boxed, say, a list of maybe + values. In that case we can still avoid allocation through the special TAG_NOTHING + and TAG_JUST tags. If the Just value is neither of those, we just use it directly + without allocation. This way, only nested maybe types (`Just(Just(x))` or `Just(Nothing)`) + are allocated, and sometimes value types like `int32` if these happen to be equal + to `kk_box_Nothing`. +--------------------------------------------------------------------------------------*/ + +static inline kk_box_t kk_box_Nothing(void) { + return kk_datatype_box(kk_datatype_from_tag(KK_TAG_NOTHING)); +} + +static inline bool kk_box_is_Nothing(kk_box_t b) { + return (b.box == kk_datatype_from_tag(KK_TAG_NOTHING).dbox); +} + +static inline bool kk_box_is_Just(kk_box_t b, kk_context_t* ctx) { + return (kk_box_is_ptr(b) && kk_block_has_tag(kk_ptr_unbox(b, ctx), KK_TAG_JUST)); +} + +static inline bool kk_box_is_maybe(kk_box_t b, kk_context_t* ctx) { + return (kk_box_is_Just(b, ctx) || kk_box_is_Nothing(b)); +} + +typedef struct kk_just_s { + struct kk_block_s _block; + kk_box_t value; +} kk_just_t; + +kk_decl_export kk_box_t kk_unbox_Just_block(kk_block_t* b, kk_borrow_t borrow, kk_context_t* ctx); + +static inline kk_box_t kk_unbox_Just(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + if (kk_box_is_ptr(b)) { + kk_block_t* bl = kk_ptr_unbox(b, ctx); + if kk_unlikely(kk_block_has_tag(bl, KK_TAG_JUST)) { + return kk_unbox_Just_block(bl, borrow, ctx); + } + } + // if borrowing we should not change refcounts, + // and if not borrowing, we consume the b + return b; +} + +static inline kk_box_t kk_box_Just(kk_box_t b, kk_context_t* ctx) { + if kk_likely(!kk_box_is_maybe(b, ctx)) { + return b; + } + else { + kk_just_t* just = kk_block_alloc_as(kk_just_t, 1, KK_TAG_JUST, ctx); + just->value = b; + return kk_ptr_box(&just->_block, ctx); + } +} + +static inline kk_datatype_t kk_datatype_as_Just(kk_box_t b) { + kk_assert_internal(!kk_box_is_maybe(b, kk_get_context())); + return kk_datatype_unbox(b); +} + +static inline kk_box_t kk_datatype_unJust(kk_datatype_t d, kk_context_t* ctx) { + kk_unused(ctx); + kk_assert_internal(!kk_datatype_has_singleton_tag(d, KK_TAG_NOTHING)); + if (kk_datatype_is_ptr(d)) { + kk_block_t* b = kk_datatype_as_ptr(d, ctx); + if (kk_block_has_tag(b, KK_TAG_JUST)) { + return kk_block_field(b, 0); + } + } + return kk_datatype_box(d); +} + +#endif // KK_MAYBE_H diff --git a/kklib/include/kklib/os.h b/kklib/include/kklib/os.h index 4f555bb71..cc49d1142 100644 --- a/kklib/include/kklib/os.h +++ b/kklib/include/kklib/os.h @@ -26,7 +26,7 @@ kk_decl_export int kk_os_read_line(kk_string_t* result, kk_context_t* ctx); kk_decl_export int kk_os_read_text_file(kk_string_t path, kk_string_t* result, kk_context_t* ctx); kk_decl_export int kk_os_write_text_file(kk_string_t path, kk_string_t content, kk_context_t* ctx); -kk_decl_export int kk_os_ensure_dir(kk_string_t dir, int mode, kk_context_t* ctx); +kk_decl_export int kk_os_ensure_dir(kk_string_t path, int mode, kk_context_t* ctx); kk_decl_export int kk_os_copy_file(kk_string_t from, kk_string_t to, bool preserve_mtime, kk_context_t* ctx); kk_decl_export bool kk_os_is_directory(kk_string_t path, kk_context_t* ctx); kk_decl_export bool kk_os_is_file(kk_string_t path, kk_context_t* ctx); @@ -35,19 +35,34 @@ kk_decl_export int kk_os_list_directory(kk_string_t dir, kk_vector_t* contents, kk_decl_export int kk_os_run_command(kk_string_t cmd, kk_string_t* output, kk_context_t* ctx); kk_decl_export int kk_os_run_system(kk_string_t cmd, kk_context_t* ctx); -kk_decl_export kk_secs_t kk_timer_ticks(kk_asecs_t* atto_secs, kk_context_t* ctx); -kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx); - -kk_decl_export kk_secs_t kk_time_unix_now(kk_asecs_t* atto_secs, kk_context_t* ctx); -kk_decl_export kk_asecs_t kk_time_resolution(kk_context_t* ctx); - kk_decl_export kk_string_t kk_compiler_version(kk_context_t* ctx); kk_decl_export kk_string_t kk_cc_name(kk_context_t* ctx); kk_decl_export kk_string_t kk_os_name(kk_context_t* ctx); kk_decl_export kk_string_t kk_cpu_arch(kk_context_t* ctx); kk_decl_export int kk_cpu_count(kk_context_t* ctx); kk_decl_export bool kk_cpu_is_little_endian(kk_context_t* ctx); +kk_decl_export int kk_cpu_address_bits(kk_context_t* ctx); +kk_decl_export bool kk_os_set_stack_size(kk_ssize_t stack_size); + + +/*-------------------------------------------------------------------------------------- + Time and timers +--------------------------------------------------------------------------------------*/ + +kk_decl_export bool kk_duration_is_zero(kk_duration_t x); +kk_decl_export bool kk_duration_is_gt(kk_duration_t x, kk_duration_t y); +kk_decl_export kk_duration_t kk_duration_sub(kk_duration_t x, kk_duration_t y); +kk_decl_export kk_duration_t kk_duration_add(kk_duration_t x, kk_duration_t y); +kk_decl_export kk_duration_t kk_duration_neg(kk_duration_t x); +kk_decl_export kk_duration_t kk_duration_from_secs(int64_t secs); +kk_decl_export kk_duration_t kk_duration_from_nsecs(int64_t nsecs); +kk_decl_export kk_duration_t kk_duration_norm(kk_duration_t x); + +kk_decl_export kk_duration_t kk_timer_ticks(kk_context_t* ctx); +kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx); + +kk_decl_export kk_duration_t kk_time_unix_now(kk_context_t* ctx); +kk_decl_export kk_asecs_t kk_time_resolution(kk_context_t* ctx); -kk_decl_export bool kk_os_set_stack_size( kk_ssize_t stack_size ); #endif // include guard diff --git a/kklib/include/kklib/platform.h b/kklib/include/kklib/platform.h index 5f1590fab..7dbaf6aab 100644 --- a/kklib/include/kklib/platform.h +++ b/kklib/include/kklib/platform.h @@ -14,7 +14,7 @@ Platform: we assume: - C99 as C compiler (syntax and library), with possible C11 extensions for threads and atomics. - Write code such that it can be compiled with a C++ compiler as well (used with msvc) - - Either a 32- or 64-bit platform (but others should be possible with few changes). + - Either a 32, 64, or 128-bit platform (but others should be possible with few changes). - The compiler can do a great job on small static inline definitions (and we avoid #define's to get better static type checks). - The compiler will inline small structs (like `struct kk_box_s{ uintptr_t u; }`) without @@ -29,60 +29,82 @@ --------------------------------------------------------------------------------------*/ /*-------------------------------------------------------------------------------------- - Integer sizes and portability: + Object size and signed/unsigned: + We limit the maximum object size (and array sizes) to at most `SIZE_MAX/2` (`PTRDIFF_MAX`) bytes + so we can always use the signed `kk_ssize_t` (instead of `size_t`) to specify sizes + and do indexing in arrays. This avoids: + - Signed/unsigned conversion (especially when mixing pointer arithmetic and lengths). + - Subtle loop bound errors (consider `for(unsigned u = 0; u < len()-1; u++)` if `len()` + happens to be `0` etc.). + - Performance degradation -- modern compilers can compile signed loop variables + better (as signed overflow is undefined). + - Wrong API usage (passing a negative value is easier to detect) + + A drawback is that this limits object sizes to half the address space-- for 64-bit + this is not a problem but string lengths for example on 32-bit are limited to be + "just" 2^31 bytes at most. Nevertheless, we feel this is an acceptible trade-off + (especially since the largest object is nowadays is already limited in practice + to `PTRDIFF_MAX` e.g. ). + + We also need some helpers to deal with API's (like `strlen`) that use `size_t` + results or arguments, where we clamp the values into the `kk_ssize_t` range + (but again, on modern systems no clamping will ever happen as these already limit the size of objects to PTRDIFF_MAX) +--------------------------------------------------------------------------------------*/ + +/*-------------------------------------------------------------------------------------- + Integer sizes and portability + Here are some architectures with the bit size of various integers, where - - `uintptr_t` for addresses (where `sizeof(uintptr_t) == sizeof(void*)`), + - `intptr_t` for addresses (where `sizeof(intptr_t) == sizeof(void*)`), - `size_t` for object sizes, - `kk_intx_t` for the natural largest register size (for general arithmetic), - - `kk_intf_t` for the natural largest register size where |kk_intf_t| <= |uintptr_t|. - (this is used to store integer values in heap fields that are the size of a `uintptr_t`. - here we want to limit the `kk_intf_t` to be at most the size of `uintptr_t` (for - example on x32) but also not too large (for example, on arm CHERI we would still - use 64-bit arithmetic)). - + - `kk_addr_t` for raw virtual adresses; usually equal to `intptr_t` but + on capability systems like CHERI, this can be smaller. + We always have: - - `|uintptr_t| >= |size_t| >= |kk_intf_t| >= |int|`. - - `|kk_intx_t| >= |kk_intf_t| >= |int|`. + - `|intptr_t| >= |kk_addr_t| >= |size_t| >= |int|`. + - `|kk_intx_t| >= |int|`. - system uintptr_t size_t int long intx intf notes - ------------------ ----------- -------- ----- ------ ------ ------ ----------- - x86, arm32 32 32 32 32 32 32 - x64, arm64, etc. 64 64 32 64 64 64 - x64 windows 64 64 32 32 64 64 size_t > long - x32 linux 32 32 32 32 64 32 intx > size_t - arm CHERI 128 64 32 64 64 64 uintptr_t > size_t - riscV 128-bit 128 128 32 64 128 128 - x86 16-bit small 16 16 16 32 16 16 long > size_t - x86 16-bit large 32 16 16 32 16 16 uintptr_t/long > size_t - x86 16-bit huge 32 32 16 32 16 16 intx < size_t - - We use a signed `size_t` as `kk_ssize_t` (see comments below) and define - `kk_intf_t` is the `min(kk_intx_t,size_t)`. ---------------------------------------------------------------------------------------*/ + system intptr_t kk_addr_t size_t int long intx notes + ------------------ ----------- --------- -------- ----- ------ ------ ----------- + x86, arm32 32 32 32 32 32 32 + x64, arm64, etc. 64 64 64 32 64 64 + x64 windows 64 64 64 32 32 64 size_t > long + x32 linux 32 32 32 32 32 64 intx_t > size_t,intptr_t + arm CHERI 128 64 64 32 64 64 intptr_t > size_t + riscV 128-bit 128 128 128 32 64 128 + x86 16-bit small 16 16 16 16 32 16 long > size_t + x86 16-bit large 32 32 16 16 32 16 intptr_t/long > size_t + x86 16-bit huge 32 32 32 16 32 16 size_t > intx_t + + We use a signed `size_t` as `kk_ssize_t` (see earlier comments) + + We also have: + - `kk_intb_t` (boxed integer) as the integer size that can hold a boxed value + - `kk_intf_t` (field integer) as the largest integer such that `|kk_intf_t| <= min(|kk_intb_t|,|kk_intx_t|)`. + + Usually `kk_intb_t` is equal to `kk_intptr_t` but it can smaller if heap + compression is used. This is controlled by the `KK_INTB_SIZE` define. + + system intptr_t size_t intx intb intf notes + ----------------------------- --------- -------- ------ ------ ------ ----------- + x64, arm64, 64 64 64 64 64 + x64, arm64 compressed 32-bit 64 64 64 32 32 limit heap to 16 GiB == 4*2^32 (*) + + arm CHERI 128 64 64 128 64 |intb| > |intf| + arm CHERI compressed 64-bit 128 64 64 64 64 store addresses only in a box + arm CHERI compressed 32-bit 128 64 64 32 32 compress address as well -/*-------------------------------------------------------------------------------------- - Object size and signed/unsigned: - We limit the maximum object size (and array sizes) to at most `SIZE_MAX/2` bytes - so we can always use the signed `kk_ssize_t` (instead of `size_t`) to specify sizes - and do indexing in arrays. This avoids: - - Signed/unsigned conversion (especially when mixing pointer arithmetic and lengths), - - Loop bound errors (consider `for(unsigned u = 0; u < len()-1; u++)` if `len()` - happens to be `0` etc.), - - Performance degradation -- modern compilers can compile signed loop variables - better (as signed overflow is undefined), - - Wrong API usage (passing a negative value is easier to detect) + riscV 128-bit 128 128 128 128 128 + riscV 128-bit compressed 64-bit 128 128 128 64 64 limit heap to 2^64 + riscV 128-bit compressed 32-bit 128 128 128 32 32 limit heap to 16 GiB == 4*2^32 (*) + x32 linux 32 32 64 32 32 |intx| > |intb| - A drawback is that this limits object sizes to half the address space-- for 64-bit - this is not a problem but string lengths for example on 32-bit are limited to be - "just" 2^31 bytes at most. Nevertheless, we feel this is an acceptible trade-off - (especially since `malloc` nowadays is already limited to `PTRDIFF_MAX`). - We also need some helpers to deal with API's (like `strlen`) that use `size_t` - results or arguments, where we clamp the values into the `kk_ssize_t` range - (but then, on modern systems no clamping will ever happen as these already limit - the size of objects to SIZE_MAX/2 internally) + (*) times 4 as we have 2 spare bits after assuming aligned addresses. --------------------------------------------------------------------------------------*/ + #if defined(__clang_major__) && __clang_major__ < 9 #error koka requires at least clang version 9 (due to atomics support) #endif @@ -95,6 +117,9 @@ #endif #ifdef __STDC_VERSION__ +#if (__STDC_VERSION__ >= 201710L) +#define KK_C17 1 +#endif #if (__STDC_VERSION__ >= 201112L) #define KK_C11 1 #endif @@ -104,10 +129,13 @@ #endif #ifdef __cplusplus -#if (__cplusplus >= 201703L) +#if (__cplusplus >= 202002L) || (defined(_MSVC_LANG) && _MSVC_LANG >= 202002L) +#define KK_CPP20 1 +#endif +#if (__cplusplus >= 201703L) || (defined(_MSVC_LANG) && _MSVC_LANG >= 201703L) #define KK_CPP17 1 #endif -#if (__cplusplus >= 201402L) +#if (__cplusplus >= 201402L) || (defined(_MSVC_LANG) && _MSVC_LANG >= 201402L) #define KK_CPP14 1 #endif #if (__cplusplus >= 201103L) || (_MSC_VER > 1900) @@ -142,14 +170,12 @@ #if defined(__GNUC__) #pragma GCC diagnostic ignored "-Wunused-variable" #pragma GCC diagnostic ignored "-Wunused-value" -#pragma GCC diagnostic ignored "-Warray-bounds" // gives wrong warnings in std/os/path for string literals -#define kk_unlikely(h) __builtin_expect((h),0) -#define kk_likely(h) __builtin_expect((h),1) -#define kk_decl_const __attribute__((const)) // reads no global state at all -#define kk_decl_pure __attribute__((pure)) // may read global state but has no observable side effects -#define kk_decl_noinline __attribute__((noinline)) -#define kk_decl_align(a) __attribute__((aligned(a))) -#define kk_decl_thread __thread +#pragma GCC diagnostic ignored "-Warray-bounds" // gives wrong warnings in std/os/path for string literals +#define kk_decl_const __attribute__((const)) // reads no global state at all +#define kk_decl_pure __attribute__((pure)) // may read global state but has no observable side effects +#define kk_decl_noinline __attribute__((noinline)) +#define kk_decl_align(a) __attribute__((aligned(a))) +#define kk_decl_thread __thread #elif defined(_MSC_VER) #pragma warning(disable:4214) // using bit field types other than int #pragma warning(disable:4101) // unreferenced local variable @@ -157,26 +183,37 @@ #pragma warning(disable:4068) // unknown pragma #pragma warning(disable:4996) // POSIX name deprecated #pragma warning(disable:26812) // the enum type is unscoped (in C++) -#define kk_unlikely(x) (x) -#define kk_likely(x) (x) #define kk_decl_const #define kk_decl_pure -#define kk_decl_noinline __declspec(noinline) -#define kk_decl_align(a) __declspec(align(a)) -#define kk_decl_thread __declspec(thread) -#ifndef __cplusplus +#define kk_decl_noinline __declspec(noinline) +#define kk_decl_align(a) __declspec(align(a)) +#define kk_decl_thread __declspec(thread) +#ifndef __cplusplus // need c++ compilation for correct atomic operations on msvc #error "when using cl (the Microsoft Visual C++ compiler), use the /TP option to always compile in C++ mode." #endif #else -#define kk_unlikely(h) (h) -#define kk_likely(h) (h) #define kk_decl_const #define kk_decl_pure #define kk_decl_noinline #define kk_decl_align(a) -#define kk_decl_thread __thread +#define kk_decl_thread __thread #endif + +#if defined(__GNUC__) || defined(__clang__) +#define kk_unlikely(x) (__builtin_expect(!!(x),false)) +#define kk_likely(x) (__builtin_expect(!!(x),true)) +#elif defined(KK_CPP20) +#define kk_unlikely(x) (x) [[unlikely]] +#define kk_likely(x) (x) [[likely]] +#else +#define kk_unlikely(x) (x) +#define kk_likely(x) (x) +#endif + +// assign const field in a struct +#define kk_assign_const(tp,field) ((tp*)&(field))[0] + // Assertions; kk_assert_internal is only enabled when KK_DEBUG_FULL is defined #define kk_assert(x) assert(x) #ifdef KK_DEBUG_FULL @@ -200,7 +237,7 @@ #endif #endif -// Defining constants of a specific size +// Defining constants of a specific size (as not all platforms define the INTXX_C macros) #if LONG_MAX == INT64_MAX # define KK_LONG_SIZE 8 # define KK_I32(i) (i) @@ -208,7 +245,7 @@ # define KK_U32(i) (i##U) # define KK_U64(i) (i##UL) #elif LONG_MAX == INT32_MAX -# define KK_LONG_SIZE 4 +# define KK_LONG_SIZE 4 # define KK_I32(i) (i##L) # define KK_I64(i) (i##LL) # define KK_U32(i) (i##UL) @@ -217,31 +254,55 @@ #error size of a `long` must be 32 or 64 bits #endif +#ifdef _MSC_VER +# define KK_I128(i) (i##i128) +# define KK_U128(i) (i##ui128) +#else +# define KK_I128(i) (INT128_C(i)) +# define KK_U128(i) (UINT128_C(i)) +#endif + +#define KK_KiB (1024) +#define KK_MiB (KK_I32(1024)*KK_KiB) +#define KK_GiB (KK_I32(1024)*KK_MiB) + + // Define size of intptr_t -#if INTPTR_MAX == INT64_MAX -# define KK_INTPTR_SIZE 8 -# define KK_IP(i) KK_I64(i) -# define KK_UP(i) KK_U64(i) +#if INTPTR_MAX == INT128_MAX +# define KK_INTPTR_SIZE 16 +# define KK_INTPTR_SHIFT 4 +# define KK_IP(i) KK_I128(i) +# define KK_UP(i) KK_U128(i) +#elif INTPTR_MAX == INT64_MAX +# define KK_INTPTR_SIZE 8 +# define KK_INTPTR_SHIFT 3 +# define KK_IP(i) KK_I64(i) +# define KK_UP(i) KK_U64(i) #elif INTPTR_MAX == INT32_MAX -# define KK_INTPTR_SIZE 4 -# define KK_IP(i) KK_I32(i) -# define KK_UP(i) KK_U32(i) +# define KK_INTPTR_SIZE 4 +# define KK_INTPTR_SHIFT 2 +# define KK_IP(i) KK_I32(i) +# define KK_UP(i) KK_U32(i) #elif INTPTR_MAX == INT16_MAX -# define KK_INTPTR_SIZE 2 -# define KK_IP(i) i -# define KK_UP(i) i -#elif INTPTR_MAX > INT64_MAX // assume 128-bit -# define KK_INTPTR_SIZE 16 -# define KK_IP(i) KK_I64(i) -# define KK_UP(i) KK_U64(i) +# define KK_INTPTR_SIZE 2 +# define KK_INTPTR_SHIFT 1 +# define KK_IP(i) i +# define KK_UP(i) i #else -#error platform addresses must be 16, 32, 64, or 128 bits +#error platform pointers must be 16, 32, 64, or 128 bits #endif #define KK_INTPTR_BITS (8*KK_INTPTR_SIZE) #define KK_INTPTR_ALIGNUP(x) ((((x)+KK_INTPTR_SIZE-1)/KK_INTPTR_SIZE)*KK_INTPTR_SIZE) // Define size of size_t and kk_ssize_t -#if SIZE_MAX == UINT64_MAX +#if SIZE_MAX == UINT128_MAX +# define KK_SIZE_SIZE 16 +# define KK_IZ(i) KK_I128(i) +# define KK_UZ(i) KK_U128(i) +# define KK_SSIZE_MAX INT64_MAX +# define KK_SSIZE_MIN INT64_MIN +typedef int64_t kk_ssize_t; +#elif SIZE_MAX == UINT64_MAX # define KK_SIZE_SIZE 8 # define KK_IZ(i) KK_I64(i) # define KK_UZ(i) KK_U64(i) @@ -263,13 +324,13 @@ typedef int32_t kk_ssize_t; # define KK_SSIZE_MIN INT16_MIN typedef int16_t kk_ssize_t; #else -#error size of a `size_t` must be 16, 32 or 64 bits +#error size of a `size_t` must be 16, 32, 64 or 128 bits #endif -#define KK_SSIZE_SIZE KK_SIZE_SIZE -#define KK_SIZE_BITS (8*KK_SIZE_SIZE) +#define KK_SSIZE_SIZE KK_SIZE_SIZE +#define KK_SIZE_BITS (8*KK_SIZE_SIZE) -// off_t: we use 64-bit file offsets (unless on a 16-bit platform) +// off_t: we use signed 64-bit file offsets (unless on a 16-bit platform) #if (INT_MAX > INT16_MAX) typedef int64_t kk_off_t; #define KK_OFF_MAX INT64_MAX @@ -280,14 +341,30 @@ typedef int32_t kk_off_t; #define KK_OFF_MIN INT32_MIN #endif +// kk_addr_t: a signed integer that can hold a plain address (usually intptr_t but may be smaller on capability architectures) +#if defined(KK_CHERI) +typedef kk_ssize_t kk_addr_t; +typedef kk_size_t kk_uaddr_t; +#define KK_ADDR_MAX KK_SSIZE_MAX +#define KK_ADDR_MIN KK_SSIZE_MIN +#define KK_ADDR_BITS KK_SIZE_BITS +#else +typedef intptr_t kk_addr_t; +typedef uintptr_t kk_uaddr_t; +#define KK_ADDR_MAX INTPTR_MAX +#define KK_ADDR_MIN INTPTR_MIN +#define KK_ADDR_BITS KK_INTPTR_BITS +#endif + + // We limit the maximum object size (and array sizes) to at most `SIZE_MAX/2` bytes. static inline kk_ssize_t kk_to_ssize_t(size_t sz) { kk_assert(sz <= KK_SSIZE_MAX); - return (kk_likely(sz <= KK_SSIZE_MAX) ? (kk_ssize_t)sz : KK_SSIZE_MAX); + return kk_likely(sz <= KK_SSIZE_MAX) ? (kk_ssize_t)sz : KK_SSIZE_MAX; } static inline size_t kk_to_size_t(kk_ssize_t sz) { kk_assert(sz >= 0); - return (kk_likely(sz >= 0) ? (size_t)sz : 0); + return kk_likely(sz >= 0) ? (size_t)sz : 0; } #if defined(NDEBUG) @@ -298,7 +375,7 @@ static inline size_t kk_to_size_t(kk_ssize_t sz) { // We define `kk_intx_t` as an integer with the natural (fast) machine register size. -// We define it such that `sizeof(kk_intx_t)` is, with `m = max(sizeof(sizeof(long),sizeof(size_t))` +// We define it such that `sizeof(kk_intx_t)` is, with `m = max(sizeof(long),sizeof(size_t))` // (m==8 || x32) ? 8 : ((m == 4 && sizeof(int) > 2) ? 4 : sizeof(int)) // (We cannot use just `long` as it is sometimes too short (as on Windows 64-bit or x32 where a `long` is 32 bits). #if (LONG_MAX == INT64_MAX) || (SIZE_MAX == UINT64_MAX) || (defined(__x86_64__) && SIZE_MAX == UINT32_MAX) /* x32 */ @@ -314,7 +391,7 @@ typedef uint64_t kk_uintx_t; #define PRIuUX PRIu64 #define PRIxUX PRIx64 #define PRIXUX PRIX64 -#elif (INT_MAX > INT16_MAX && (LONG_MAX == INT32_MAX) || (SIZE_MAX == UINT32_MAX)) +#elif (INT_MAX > INT16_MAX && LONG_MAX == INT32_MAX) || (SIZE_MAX == UINT32_MAX) typedef int32_t kk_intx_t; typedef uint32_t kk_uintx_t; #define KK_IX(i) KK_I32(i) @@ -336,56 +413,108 @@ typedef unsigned kk_uintx_t; #define KK_INTX_MAX INT_MAX #define KK_INTX_MIN INT_MIN #define KK_UINTX_MAX UINT_MAX -#define PRIdIX "%d" -#define PRIuUX "%u" -#define PRIxUX "%x" -#define PRIXUX "%X" +#define PRIdIX "d" +#define PRIuUX "u" +#define PRIxUX "x" +#define PRIXUX "X" #else #error "platform cannot be determined to have natural 16, 32, or 64 bit registers" #endif #define KK_INTX_BITS (8*KK_INTX_SIZE) -// `sizeof(kk_intf_t)` is `min(sizeof(kk_intx_t),sizeof(size_t))` -#if (KK_INTX_SIZE > KK_SIZE_SIZE) -typedef kk_ssize_t kk_intf_t; -typedef size_t kk_uintf_t; -#define KK_UF(i) KK_UZ(i) -#define KK_IF(i) KK_IZ(i) -#define KK_INTF_SIZE KK_SSIZE_SIZE -#define KK_INTF_MAX KK_SSIZE_MAX -#define KK_INTF_MIN KK_SSIZE_MIN -#define KK_UINTF_MAX SIZE_MAX + +// a boxed value is by default the size of an `intptr_t`. +#if !defined(KK_INTB_SIZE) +#define KK_INTB_SIZE KK_INTPTR_SIZE +#endif +#define KK_INTB_BITS (8*KK_INTB_SIZE) + +// define `kk_intb_t` (the integer that can hold a boxed value) +#if (KK_INTB_SIZE == KK_INTPTR_SIZE) +#define KK_COMPRESS 0 +typedef intptr_t kk_intb_t; +typedef uintptr_t kk_uintb_t; +#define KK_INTB_MAX INTPTR_MAX +#define KK_INTB_MIN INTPTR_MIN +#define KK_UINTB_MAX UINTPTR_MAX +#define KK_IB(i) KK_IP(i) +#define KK_UB(i) KK_UP(i) +#define PRIdIB "zd" +#elif (KK_INTB_SIZE == 8 && KK_INTB_SIZE < KK_INTPTR_SIZE) +// 128-bit systems with 64-bit compressed pointers +#define KK_COMPRESS 1 +typedef int64_t kk_intb_t; +typedef uint64_t kk_uintb_t; +#define KK_INTB_MAX INT64_MAX +#define KK_INTB_MIN INT64_MIN +#define KK_UINTB_MAX UINT64_MAX +#define KK_IB(i) KK_I64(i) +#define KK_UB(i) KK_U64(i) +#define PRIdIB PRIdI64 +#elif (KK_INTB_SIZE == 4 && KK_INTB_SIZE < KK_INTPTR_SIZE) +// 64- or 128-bit systems with 32-bit compressed pointers (and a 4*4GiB heap) +#define KK_COMPRESS 1 +typedef int32_t kk_intb_t; +typedef uint32_t kk_uintb_t; +#define KK_INTB_MAX INT32_MAX +#define KK_INTB_MIN INT32_MIN +#define KK_UINTB_MAX UINT32_MAX +#define KK_IB(i) KK_I32(i) +#define KK_UB(i) KK_U32(i) +#define PRIdIB PRIdI32 #else +#error "the given platform boxed integer size is (currently) not supported" +#endif + + +// A "field" integer is the largest natural integer that fits into a boxed value +#if (KK_INTB_SIZE > KK_INTX_SIZE) // ensure it fits the natural register size typedef kk_intx_t kk_intf_t; typedef kk_uintx_t kk_uintf_t; -#define KK_UF(i ) KK_UX(i) #define KK_IF(i) KK_IX(i) #define KK_INTF_SIZE KK_INTX_SIZE #define KK_INTF_MAX KK_INTX_MAX #define KK_INTF_MIN KK_INTX_MIN #define KK_UINTF_MAX KK_UINTX_MAX +#define PRIdIF PRIdIX +#else +typedef kk_intb_t kk_intf_t; +typedef kk_uintb_t kk_uintf_t; +#define KK_IF(i) KK_IB(i) +#define KK_INTF_SIZE KK_INTB_SIZE +#define KK_INTF_MAX KK_INTB_MAX +#define KK_INTF_MIN KK_INTB_MIN +#define KK_UINTF_MAX KK_UINTB_MAX +#define PRIdIF PRIdIB #endif #define KK_INTF_BITS (8*KK_INTF_SIZE) // Distinguish unsigned shift right and signed arithmetic shift right. // (Here we assume >> is arithmetic right shift). Avoid UB by always masking the shift. -static inline kk_intx_t kk_sar(kk_intx_t i, kk_intx_t shift) { return (i >> (shift & (KK_INTX_BITS - 1))); } -static inline kk_uintx_t kk_shr(kk_uintx_t u, kk_intx_t shift) { return (u >> (shift & (KK_INTX_BITS - 1))); } -static inline kk_intf_t kk_sarf(kk_intf_t i, kk_intf_t shift) { return (i >> (shift & (KK_INTF_BITS - 1))); } -static inline kk_uintf_t kk_shrf(kk_uintf_t u, kk_intf_t shift){ return (u >> (shift & (KK_INTF_BITS - 1))); } -static inline uintptr_t kk_shrp(uintptr_t u, kk_intx_t shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } -static inline int32_t kk_sar32(int32_t i, int32_t shift) { return (i >> (shift & 31)); } -static inline uint32_t kk_shr32(uint32_t u, int32_t shift) { return (u >> (shift & 31)); } -static inline int64_t kk_sar64(int64_t i, int64_t shift) { return (i >> (shift & 63)); } -static inline uint64_t kk_shr64(uint64_t u, int64_t shift) { return (u >> (shift & 63)); } +static inline kk_intx_t kk_sar(kk_intx_t i, int shift) { return (i >> (shift & (KK_INTX_BITS - 1))); } +static inline kk_uintx_t kk_shr(kk_uintx_t u, int shift) { return (u >> (shift & (KK_INTX_BITS - 1))); } +static inline kk_intf_t kk_sarf(kk_intf_t i, int shift) { return (i >> (shift & (KK_INTF_BITS - 1))); } +static inline kk_uintf_t kk_shrf(kk_uintf_t u, int shift) { return (u >> (shift & (KK_INTF_BITS - 1))); } +static inline kk_intb_t kk_sarb(kk_intb_t i, int shift) { return (i >> (shift & (KK_INTB_BITS - 1))); } +static inline kk_addr_t kk_sara(kk_addr_t i, int shift) { return (i >> (shift & (KK_ADDR_BITS - 1))); } + +static inline uintptr_t kk_shrp(uintptr_t u, int shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } +static inline intptr_t kk_sarp(intptr_t u, int shift) { return (u >> (shift & (KK_INTPTR_BITS - 1))); } +static inline int32_t kk_sar32(int32_t i, int32_t shift) { return (i >> (shift & 31)); } +static inline uint32_t kk_shr32(uint32_t u, int32_t shift) { return (u >> (shift & 31)); } +static inline int64_t kk_sar64(int64_t i, int64_t shift) { return (i >> (shift & 63)); } +static inline uint64_t kk_shr64(uint64_t u, int64_t shift) { return (u >> (shift & 63)); } // Avoid UB by left shifting on unsigned integers (and masking the shift). -static inline kk_intx_t kk_shl(kk_intx_t i, kk_intx_t shift) { return (kk_intx_t)((kk_uintx_t)i << (shift & (KK_INTX_BITS - 1))); } -static inline kk_intf_t kk_shlf(kk_intf_t i, kk_intf_t shift) { return (kk_intf_t)((kk_uintf_t)i << (shift & (KK_INTF_BITS - 1))); } -static inline int32_t kk_shl32(int32_t i, int32_t shift) { return (int32_t) ((uint32_t)i << (shift & 31)); } -static inline int64_t kk_shl64(int64_t i, int64_t shift) { return (int64_t) ((uint64_t)i << (shift & 63)); } -static inline intptr_t kk_shlp(intptr_t i, intptr_t shift) { return (intptr_t) ((uintptr_t)i << (shift & (KK_INTPTR_BITS - 1))); } +static inline kk_intx_t kk_shl(kk_intx_t i, int shift) { return (kk_intx_t)((kk_uintx_t)i << (shift & (KK_INTX_BITS - 1))); } +static inline kk_intf_t kk_shlf(kk_intf_t i, int shift) { return (kk_intf_t)((kk_uintf_t)i << (shift & (KK_INTF_BITS - 1))); } +static inline kk_intb_t kk_shlb(kk_intb_t i, int shift) { return (kk_intb_t)((kk_uintb_t)i << (shift & (KK_INTB_BITS - 1))); } +static inline kk_addr_t kk_shla(kk_addr_t i, int shift) { return (kk_addr_t)((kk_uaddr_t)i << (shift & (KK_ADDR_BITS - 1))); } +static inline intptr_t kk_shlp(intptr_t i, int shift) { return (intptr_t)((uintptr_t)i << (shift & (KK_INTPTR_BITS - 1))); } +static inline int32_t kk_shl32(int32_t i, int32_t shift) { return (int32_t)((uint32_t)i << (shift & 31)); } +static inline int64_t kk_shl64(int64_t i, int64_t shift) { return (int64_t)((uint64_t)i << (shift & 63)); } + // Architecture assumptions diff --git a/kklib/include/kklib/process.h b/kklib/include/kklib/process.h index ff51ae2cd..6f9df2894 100644 --- a/kklib/include/kklib/process.h +++ b/kklib/include/kklib/process.h @@ -9,15 +9,9 @@ terms of the Apache License, Version 2.0. A copy of the License can be found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ - -typedef int64_t kk_msecs_t; -typedef int64_t kk_usecs_t; -typedef kk_usecs_t kk_timer_t; - -kk_timer_t kk_timer_start(void); -kk_usecs_t kk_timer_end(kk_timer_t start); -void kk_process_info(kk_msecs_t* utime, kk_msecs_t* stime, - size_t* peak_rss, size_t* page_faults, size_t* page_reclaim, size_t* peak_commit); +typedef int64_t kk_msecs_t; +void kk_process_info(kk_msecs_t* utime, kk_msecs_t* stime, + size_t* peak_rss, size_t* page_faults, size_t* page_reclaim, size_t* peak_commit); #endif // include guard diff --git a/kklib/include/kklib/random.h b/kklib/include/kklib/random.h index 1dab8c65a..aec9894c3 100644 --- a/kklib/include/kklib/random.h +++ b/kklib/include/kklib/random.h @@ -24,7 +24,7 @@ kk_decl_export kk_random_ctx_t* kk_srandom_round(kk_context_t* ctx); // Initial randomness comes from the OS. static inline uint32_t kk_srandom_uint32(kk_context_t* ctx) { kk_random_ctx_t* rnd = ctx->srandom_ctx; - if (kk_unlikely(rnd == NULL || rnd->used >= 16)) { + if kk_unlikely(rnd == NULL || rnd->used >= 16) { rnd = kk_srandom_round(ctx); kk_assert_internal(rnd != NULL && rnd->used >= 0 && rnd->used < 16); } @@ -36,7 +36,7 @@ static inline uint32_t kk_srandom_uint32(kk_context_t* ctx) { static inline uint64_t kk_srandom_uint64(kk_context_t* ctx) { // return (((uint64_t)kk_srandom_uint32(ctx) << 32) | kk_srandom_uint32(ctx)); kk_random_ctx_t* rnd = ctx->srandom_ctx; - if (kk_unlikely(rnd == NULL || rnd->used >= 15)) { + if kk_unlikely(rnd == NULL || rnd->used >= 15) { rnd = kk_srandom_round(ctx); kk_assert_internal(rnd != NULL && rnd->used >= 0 && rnd->used < 15); } diff --git a/kklib/include/kklib/ref.h b/kklib/include/kklib/ref.h new file mode 100644 index 000000000..7038009d9 --- /dev/null +++ b/kklib/include/kklib/ref.h @@ -0,0 +1,93 @@ +#pragma once +#ifndef KK_REF_H +#define KK_REF_H +/*--------------------------------------------------------------------------- + Copyright 2020-2022, Microsoft Research, Daan Leijen. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the LICENSE file at the root of this distribution. +---------------------------------------------------------------------------*/ + +/*-------------------------------------------------------------------------------------- + Mutable references cells +--------------------------------------------------------------------------------------*/ + +struct kk_ref_s { + kk_block_t _block; + _Atomic(kk_intb_t) value; +}; +typedef kk_datatype_ptr_t kk_ref_t; + +kk_decl_export kk_box_t kk_ref_get_thread_shared(struct kk_ref_s* r, kk_context_t* ctx); +kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(struct kk_ref_s* r, kk_box_t value); +kk_decl_export kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx); + +static inline kk_decl_const kk_box_t kk_ref_box(kk_ref_t r, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_ptr_box(r); +} + +static inline kk_decl_const kk_ref_t kk_ref_unbox(kk_box_t b, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_ptr_unbox_assert(b, KK_TAG_REF, ctx); +} + +static inline void kk_ref_drop(kk_ref_t r, kk_context_t* ctx) { + kk_datatype_ptr_drop_assert(r, KK_TAG_REF, ctx); +} + +static inline kk_ref_t kk_ref_dup(kk_ref_t r, kk_context_t* ctx) { + return kk_datatype_ptr_dup_assert(r, KK_TAG_REF, ctx); +} + +static inline kk_ref_t kk_ref_alloc(kk_box_t value, kk_context_t* ctx) { + struct kk_ref_s* r = kk_block_alloc_as(struct kk_ref_s, 1, KK_TAG_REF, ctx); + kk_atomic_store_relaxed(&r->value,value.box); + return kk_datatype_from_base(r,ctx); +} + +static inline kk_box_t kk_ref_get(kk_ref_t _r, kk_context_t* ctx) { + struct kk_ref_s* r = kk_datatype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); + if kk_likely(!kk_block_is_thread_shared(&r->_block)) { + // fast path + kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); + kk_box_dup(b,ctx); + kk_block_drop(&r->_block,ctx); // TODO: make references borrowed (only get left) + return b; + } + else { + // thread shared + return kk_ref_get_thread_shared(r,ctx); + } +} + +static inline kk_box_t kk_ref_swap_borrow(kk_ref_t _r, kk_box_t value, kk_context_t* ctx) { + struct kk_ref_s* r = kk_datatype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); + if kk_likely(!kk_block_is_thread_shared(&r->_block)) { + // fast path + kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); + kk_atomic_store_relaxed(&r->value, value.box); + return b; + } + else { + // thread shared + return kk_ref_swap_thread_shared_borrow(r, value); + } +} + + +static inline kk_unit_t kk_ref_set_borrow(kk_ref_t r, kk_box_t value, kk_context_t* ctx) { + kk_box_t b = kk_ref_swap_borrow(r, value, ctx); + kk_box_drop(b, ctx); + return kk_Unit; +} + +// In Koka we can constrain the argument of f to be a local-scope reference. +static inline kk_box_t kk_ref_modify(kk_ref_t r, kk_function_t f, kk_context_t* ctx) { + return kk_function_call(kk_box_t,(kk_function_t,kk_ref_t,kk_context_t*),f,(f,r,ctx),ctx); +} + + + +#endif // KK_REF_H diff --git a/kklib/include/kklib/string.h b/kklib/include/kklib/string.h index bc84741dc..5055092ca 100644 --- a/kklib/include/kklib/string.h +++ b/kklib/include/kklib/string.h @@ -107,22 +107,34 @@ static inline kk_string_t kk_unsafe_bytes_as_string_unchecked(kk_bytes_t b) { } static inline kk_string_t kk_unsafe_bytes_as_string(kk_bytes_t b) { - kk_assert_internal(kk_datatype_tag(b) == KK_TAG_BOX_ANY || kk_utf8_is_valid(kk_bytes_cbuf_borrow(b, NULL))); + kk_assert_internal(kk_datatype_tag(b,kk_get_context()) == KK_TAG_BOX_ANY || kk_utf8_is_valid(kk_bytes_cbuf_borrow(b, NULL, kk_get_context()))); return kk_unsafe_bytes_as_string_unchecked(b); } -static inline kk_string_t kk_string_empty(void) { +static inline kk_string_t kk_string_empty() { return kk_unsafe_bytes_as_string( kk_bytes_empty() ); } // Define string literals +#if 0 #define kk_define_string_literal(decl,name,len,chars) \ static struct { struct kk_bytes_s _base; size_t length; char str[len+1]; } _static_##name = \ { { { KK_HEADER_STATIC(0,KK_TAG_STRING) } }, len, chars }; \ - decl kk_string_t name = { { (uintptr_t)&_static_##name._base._block } }; + decl kk_string_t name = { { (intptr_t)&_static_##name._base._block } }; +#else +#define kk_declare_string_literal(decl,name,len,chars) \ + static kk_ssize_t _static_len_##name = len; \ + static const char* _static_##name = chars; \ + decl kk_string_t name = { { kk_datatype_null_init } }; -#define kk_define_string_literal_empty(decl,name) \ - decl kk_string_t name = { { (kk_block_t*)((uintptr_t)(5)) } }; +#define kk_init_string_literal(name,ctx) \ + if (kk_datatype_is_null(name.bytes)) { name = kk_string_alloc_from_utf8n(_static_len_##name, _static_##name, ctx); } + +#define kk_define_string_literal(decl,name,len,chars,ctx) \ + kk_declare_string_literal(decl,name,len,chars) \ + kk_init_string_literal(name,ctx) + +#endif static inline kk_string_t kk_string_unbox(kk_box_t v) { return kk_unsafe_bytes_as_string( kk_bytes_unbox(v) ); @@ -136,8 +148,8 @@ static inline void kk_string_drop(kk_string_t str, kk_context_t* ctx) { kk_bytes_drop(str.bytes, ctx); } -static inline kk_string_t kk_string_dup(kk_string_t str) { - return kk_unsafe_bytes_as_string(kk_bytes_dup(str.bytes)); +static inline kk_string_t kk_string_dup(kk_string_t str, kk_context_t* ctx) { + return kk_unsafe_bytes_as_string(kk_bytes_dup(str.bytes,ctx)); } @@ -148,8 +160,8 @@ typedef int32_t kk_char_t; #define kk_char_replacement KK_I32(0xFFFD) -static inline kk_char_t kk_char_unbox(kk_box_t b, kk_context_t* ctx) { - return (kk_char_t)kk_int32_unbox(b, ctx); +static inline kk_char_t kk_char_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return (kk_char_t)kk_int32_unbox(b, borrow, ctx); } static inline kk_box_t kk_char_box(kk_char_t c, kk_context_t* ctx) { @@ -228,28 +240,32 @@ static inline kk_string_t kk_string_alloc_raw(const char* s, bool free, kk_conte return kk_string_alloc_raw_len(kk_sstrlen(s), s, free, ctx); } -static inline const uint8_t* kk_string_buf_borrow(const kk_string_t str, kk_ssize_t* len) { - return kk_bytes_buf_borrow(str.bytes, len); +static inline const uint8_t* kk_string_buf_borrow(const kk_string_t str, kk_ssize_t* len, kk_context_t* ctx) { + return kk_bytes_buf_borrow(str.bytes, len, ctx); } -static inline const char* kk_string_cbuf_borrow(const kk_string_t str, kk_ssize_t* len) { - return (const char*)kk_string_buf_borrow(str, len); +static inline const char* kk_string_cbuf_borrow(const kk_string_t str, kk_ssize_t* len, kk_context_t* ctx) { + return (const char*)kk_string_buf_borrow(str, len, ctx); } -static inline int kk_string_cmp_cstr_borrow(const kk_string_t s, const char* t) { - return strcmp(kk_string_cbuf_borrow(s,NULL), t); +static inline int kk_string_cmp_cstr_borrow(const kk_string_t s, const char* t, kk_context_t* ctx) { + return strcmp(kk_string_cbuf_borrow(s,NULL,ctx), t); } -static inline kk_ssize_t kk_decl_pure kk_string_len_borrow(const kk_string_t str) { - return kk_bytes_len_borrow(str.bytes); +static inline kk_ssize_t kk_decl_pure kk_string_len_borrow(const kk_string_t str, kk_context_t* ctx) { + return kk_bytes_len_borrow(str.bytes,ctx); } static inline kk_ssize_t kk_decl_pure kk_string_len(kk_string_t str, kk_context_t* ctx) { // bytes in UTF8 - kk_ssize_t len = kk_string_len_borrow(str); + kk_ssize_t len = kk_string_len_borrow(str,ctx); kk_string_drop(str, ctx); return len; } +static inline kk_integer_t kk_decl_pure kk_string_len_int(kk_string_t str, kk_context_t* ctx) { // bytes in UTF8 + return kk_integer_from_ssize_t(kk_string_len(str,ctx),ctx); +} + static inline kk_string_t kk_string_copy(kk_string_t str, kk_context_t* ctx) { return kk_unsafe_bytes_as_string(kk_bytes_copy(str.bytes, ctx)); } @@ -258,8 +274,8 @@ static inline bool kk_string_ptr_eq_borrow(kk_string_t s1, kk_string_t s2) { return kk_bytes_ptr_eq_borrow(s1.bytes, s2.bytes); } -static inline bool kk_string_is_empty_borrow(kk_string_t s) { - return (kk_string_len_borrow(s) == 0); +static inline bool kk_string_is_empty_borrow(kk_string_t s, kk_context_t* ctx) { + return (kk_string_len_borrow(s,ctx) == 0); } static inline bool kk_string_is_empty(kk_string_t s, kk_context_t* ctx) { @@ -299,7 +315,7 @@ kk_decl_export kk_char_t kk_utf8_read_validate(const uint8_t* s, kk_ssize_t* cou kk_decl_export kk_char_t kk_utf8_readx(const uint8_t* s, kk_ssize_t* count); static inline kk_char_t kk_utf8_read(const uint8_t* s, kk_ssize_t* count) { kk_char_t c = *s; - if (kk_likely(c <= 0x7F)) { + if kk_likely(c <= 0x7F) { *count = 1; return c; } @@ -311,13 +327,13 @@ static inline kk_char_t kk_utf8_read(const uint8_t* s, kk_ssize_t* count) { // Number of bytes needed to represent a single code point kk_decl_export kk_ssize_t kk_utf8_lenx(kk_char_t c); static inline kk_ssize_t kk_utf8_len(kk_char_t c) { - return (kk_likely(c <= 0x7F) ? 1 : kk_utf8_lenx(c)); + return kk_likely(c <= 0x7F) ? 1 : kk_utf8_lenx(c); } // utf-8 encode a single codepoint kk_decl_export void kk_utf8_writex(kk_char_t c, uint8_t* s, kk_ssize_t* count); static inline void kk_utf8_write(kk_char_t c, uint8_t* s, kk_ssize_t* count) { - if (kk_likely(c <= 0x7F)) { + if kk_likely(c <= 0x7F) { *count = 1; s[0] = (uint8_t)c; } @@ -369,20 +385,20 @@ static inline kk_string_t kk_string_alloc_from_qutf16w(const wchar_t* wstr, k Utilities that can use the bytes functions --------------------------------------------------------------------------------------------------*/ -static inline int kk_string_cmp_borrow(kk_string_t str1, kk_string_t str2) { - return kk_bytes_cmp_borrow(str1.bytes, str2.bytes); +static inline int kk_string_cmp_borrow(kk_string_t str1, kk_string_t str2, kk_context_t* ctx) { + return kk_bytes_cmp_borrow(str1.bytes, str2.bytes,ctx); } static inline int kk_string_cmp(kk_string_t str1, kk_string_t str2, kk_context_t* ctx) { return kk_bytes_cmp(str1.bytes, str2.bytes, ctx); } -static inline bool kk_string_is_eq_borrow(kk_string_t s1, kk_string_t s2) { - return (kk_string_cmp_borrow(s1, s2) == 0); +static inline bool kk_string_is_eq_borrow(kk_string_t s1, kk_string_t s2, kk_context_t* ctx) { + return (kk_string_cmp_borrow(s1, s2, ctx) == 0); } -static inline bool kk_string_is_neq_borrow(kk_string_t s1, kk_string_t s2) { - return (kk_string_cmp_borrow(s1, s2) != 0); +static inline bool kk_string_is_neq_borrow(kk_string_t s1, kk_string_t s2, kk_context_t* ctx) { + return (kk_string_cmp_borrow(s1, s2, ctx) != 0); } static inline bool kk_string_is_eq(kk_string_t s1, kk_string_t s2, kk_context_t* ctx) { @@ -438,11 +454,11 @@ static inline bool kk_string_contains(kk_string_t str, kk_string_t sub, kk_con Utilities that are string specific --------------------------------------------------------------------------------------------------*/ -kk_decl_export kk_ssize_t kk_decl_pure kk_string_count_borrow(kk_string_t str); // number of code points +kk_decl_export kk_ssize_t kk_decl_pure kk_string_count_borrow(kk_string_t str, kk_context_t* ctx); // number of code points kk_decl_export kk_ssize_t kk_decl_pure kk_string_count(kk_string_t str, kk_context_t* ctx); // number of code points -kk_decl_export kk_ssize_t kk_decl_pure kk_string_count_pattern_borrow(kk_string_t str, kk_string_t pattern); +kk_decl_export kk_ssize_t kk_decl_pure kk_string_count_pattern_borrow(kk_string_t str, kk_string_t pattern, kk_context_t* ctx); -kk_decl_export int kk_string_icmp_borrow(kk_string_t str1, kk_string_t str2); // ascii case insensitive +kk_decl_export int kk_string_icmp_borrow(kk_string_t str1, kk_string_t str2, kk_context_t* ctx); // ascii case insensitive kk_decl_export int kk_string_icmp(kk_string_t str1, kk_string_t str2, kk_context_t* ctx); // ascii case insensitive diff --git a/kklib/include/kklib/vector.h b/kklib/include/kklib/vector.h new file mode 100644 index 000000000..2eb1ff55a --- /dev/null +++ b/kklib/include/kklib/vector.h @@ -0,0 +1,115 @@ +#pragma once +#ifndef KK_VECTOR_H +#define KK_VECTOR_H +/*--------------------------------------------------------------------------- + Copyright 2020-2022, Microsoft Research, Daan Leijen. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the LICENSE file at the root of this distribution. +---------------------------------------------------------------------------*/ + + +/*-------------------------------------------------------------------------------------- + Vectors : arrays of boxed values +--------------------------------------------------------------------------------------*/ + +typedef struct kk_vector_large_s { // always use a large block for a vector so the offset to the elements is fixed + struct kk_block_large_s _base; + kk_box_t vec[1]; // vec[(large_)scan_fsize - 1] +} *kk_vector_large_t; + + +static inline kk_decl_const kk_vector_t kk_vector_empty(void) { + return kk_datatype_from_tag((kk_tag_t)1); +} + +static inline kk_decl_pure kk_vector_large_t kk_vector_as_large_borrow(kk_vector_t v, kk_context_t* ctx) { + if (kk_datatype_is_singleton(v)) { + return NULL; + } + else { + return kk_datatype_as_assert(kk_vector_large_t, v, KK_TAG_VECTOR, ctx); + } +} + +static inline void kk_vector_drop(kk_vector_t v, kk_context_t* ctx) { + kk_datatype_drop(v, ctx); +} + +static inline kk_vector_t kk_vector_dup(kk_vector_t v, kk_context_t* ctx) { + return kk_datatype_dup(v,ctx); +} + +static inline kk_vector_t kk_vector_alloc_uninit(kk_ssize_t length, kk_box_t** buf, kk_context_t* ctx) { + if kk_unlikely(length<=0) { + if (buf != NULL) *buf = NULL; + return kk_vector_empty(); + } + else { + kk_vector_large_t v = (kk_vector_large_t)kk_block_large_alloc( + kk_ssizeof(struct kk_vector_large_s) + (length-1)*kk_ssizeof(kk_box_t), // length-1 as the vector_large_s already includes one element + length + 1, // +1 to include the kk_large_scan_fsize field itself + KK_TAG_VECTOR, ctx); + if (buf != NULL) *buf = &v->vec[0]; + return kk_datatype_from_base(&v->_base,ctx); + } +} + +kk_decl_export void kk_vector_init_borrow(kk_vector_t _v, kk_ssize_t start, kk_box_t def, kk_context_t* ctx); +kk_decl_export kk_vector_t kk_vector_realloc(kk_vector_t vec, kk_ssize_t newlen, kk_box_t def, kk_context_t* ctx); +kk_decl_export kk_vector_t kk_vector_copy(kk_vector_t vec, kk_context_t* ctx); + +static inline kk_vector_t kk_vector_alloc(kk_ssize_t length, kk_box_t def, kk_context_t* ctx) { + kk_vector_t v = kk_vector_alloc_uninit(length, NULL, ctx); + kk_vector_init_borrow(v, 0, def, ctx); + return v; +} + +static inline kk_box_t* kk_vector_buf_borrow(kk_vector_t vd, kk_ssize_t* len, kk_context_t* ctx) { + kk_vector_large_t v = kk_vector_as_large_borrow(vd,ctx); + if kk_unlikely(v==NULL) { + if (len != NULL) *len = 0; + return NULL; + } + else { + if (len != NULL) { + *len = (kk_ssize_t)kk_intf_unbox(v->_base.large_scan_fsize) - 1; // exclude the large scan_fsize field itself + kk_assert_internal(*len + 1 == kk_block_scan_fsize(&v->_base._block)); + kk_assert_internal(*len > 0); + } + return &(v->vec[0]); + } +} + +static inline kk_decl_pure kk_ssize_t kk_vector_len_borrow(const kk_vector_t v, kk_context_t* ctx) { + kk_ssize_t len; + kk_vector_buf_borrow(v, &len, ctx); + return len; +} + +static inline kk_ssize_t kk_vector_len(const kk_vector_t v, kk_context_t* ctx) { + kk_ssize_t len = kk_vector_len_borrow(v,ctx); + kk_vector_drop(v, ctx); + return len; +} + +static inline kk_box_t kk_vector_at_borrow(const kk_vector_t v, kk_ssize_t i, kk_context_t* ctx) { + kk_assert(i < kk_vector_len_borrow(v,ctx)); + kk_box_t res = kk_box_dup(kk_vector_buf_borrow(v, NULL, ctx)[i],ctx); + return res; +} + +static inline kk_decl_const kk_box_t kk_vector_box(kk_vector_t v, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_box(v); +} + +static inline kk_decl_const kk_vector_t kk_vector_unbox(kk_box_t v, kk_context_t* ctx) { + kk_unused(ctx); + return kk_datatype_unbox(v); +} + + + +#endif // KK_VECTOR_H diff --git a/kklib/mimalloc b/kklib/mimalloc index f2b6938d6..10efe291a 160000 --- a/kklib/mimalloc +++ b/kklib/mimalloc @@ -1 +1 @@ -Subproject commit f2b6938d64d555f2053612da2e84fcb128bd9116 +Subproject commit 10efe291af16d04301c86d37133e97d77250719b diff --git a/kklib/src/all.c b/kklib/src/all.c index 1dadb4132..cb6e1eb55 100644 --- a/kklib/src/all.c +++ b/kklib/src/all.c @@ -7,15 +7,21 @@ ---------------------------------------------------------------------------*/ #define _BSD_SOURCE #define _DEFAULT_SOURCE -#define __USE_MINGW_ANSI_STDIO // so %z is valid on mingw - +#define __USE_MINGW_ANSI_STDIO 1 // so %z is valid on mingw #if defined(KK_MIMALLOC) -#if !defined(MI_MAX_ALIGN_SIZE) && (KK_MIMALLOC > 1) -#define MI_MAX_ALIGN_SIZE KK_MIMALLOC + #if !defined(MI_MAX_ALIGN_SIZE) + #if (KK_MIMALLOC > 1) + #define MI_MAX_ALIGN_SIZE KK_MIMALLOC + #else + #define MI_MAX_ALIGN_SIZE KK_INTPTR_SIZE + #endif + #endif + #if !defined(MI_DEBUG) && defined(KK_DEBUG_FULL) + #define MI_DEBUG 3 + #endif + #include "../mimalloc/src/static.c" // must come first on freeBSD #endif -#include "../mimalloc/src/static.c" // must come first on freeBSD -#endif #include diff --git a/kklib/src/bits.c b/kklib/src/bits.c index 7cf64ed5f..95fba1149 100644 --- a/kklib/src/bits.c +++ b/kklib/src/bits.c @@ -7,14 +7,14 @@ ---------------------------------------------------------------------------*/ #include "kklib.h" -uint32_t kk_bits_generic_count32(uint32_t x) { +int kk_bits_generic_popcount32(uint32_t x) { x = x - ((x >> 1) & KK_U32(0x55555555)); x = (x & KK_U32(0x33333333)) + ((x >> 2) & KK_U32(0x33333333)); x = (x + (x >> 4)) & KK_U32(0x0F0F0F0F); return kk_bits_byte_sum32(x); } -uint64_t kk_bits_generic_count64(uint64_t x) { +int kk_bits_generic_popcount64(uint64_t x) { x = x - ((x >> 1) & KK_U64(0x5555555555555555)); x = (x & KK_U64(0x3333333333333333)) + ((x >> 2) & KK_U64(0x3333333333333333)); x = (x + (x >> 4)) & KK_U64(0x0F0F0F0F0F0F0F0F); @@ -31,19 +31,19 @@ static const kk_uintx_t powers_of_10[] = { #endif }; -uint8_t kk_bits_digits32(uint32_t u) { - static const uint8_t guess[33] = { +int kk_bits_digits32(uint32_t u) { + static const int8_t guess[33] = { 1, 0, 0, 0, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, 8, 8, 8, 9, 9, 9 }; - uint8_t count = guess[32 - kk_bits_clz32(u)]; // = 1 + (KU32(9)*(31 - kk_bits_clz32(u)) >> 5); + const int count = guess[32 - kk_bits_clz32(u)]; // = 1 + (KU32(9)*(31 - kk_bits_clz32(u)) >> 5); return (count + (u >= powers_of_10[count] ? 1 : 0)); } -uint8_t kk_bits_digits64(uint64_t u) { - static const uint8_t guess[65] = { +int kk_bits_digits64(uint64_t u) { + static const int8_t guess[65] = { 1, 0, 0, 0, 1, 1, 1, 2, 2, 2, 3, 3, 3, 3, 4, 4, 4, 5, 5, 5, 6, 6, 6, 6, 7, 7, 7, 8, 8, 8, @@ -52,24 +52,26 @@ uint8_t kk_bits_digits64(uint64_t u) { 15,15,15,15,16,16,16,17,17,17, 18,18,18,18,19 }; - uint8_t count = guess[64 - kk_bits_clz64(u)]; // = 1 + (KU64(1233)*(63 - kk_bits_clz64(u)) >> 12); + const int count = guess[64 - kk_bits_clz64(u)]; // = 1 + (KU64(1233)*(63 - kk_bits_clz64(u)) >> 12); return (count + (u >= powers_of_10[count] ? 1 : 0)); } #if defined(KK_BITS_USE_GENERIC_CTZ_CLZ) -uint8_t kk_bits_ctz32(uint32_t x) { +int kk_bits_ctz32(uint32_t x) { // de Bruijn multiplication, see - static const unsigned char debruijn[32] = { + static const int8_t debruijn[32] = { 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 }; - return debruijn[((x & -(int32_t)x) * KK_U32(0x077CB531)) >> 27]; + if (x == 0) return 32; + x = kk_bits_only_keep_lsb32(x); + return debruijn[(uint32_t)(x * KK_U32(0x077CB531)) >> 27]; } -uint8_t kk_bits_clz32(uint32_t x) { +int kk_bits_clz32(uint32_t x) { // de Bruijn multiplication, see - static const uint8_t debruijn[32] = { + static const int8_t debruijn[32] = { 31, 22, 30, 21, 18, 10, 29, 2, 20, 17, 15, 13, 9, 6, 28, 1, 23, 19, 11, 3, 16, 14, 7, 24, 12, 4, 8, 25, 5, 26, 27, 0 }; diff --git a/kklib/src/box.c b/kklib/src/box.c index 3407a0ec9..8d8428e47 100644 --- a/kklib/src/box.c +++ b/kklib/src/box.c @@ -7,6 +7,19 @@ ---------------------------------------------------------------------------*/ #include "kklib.h" +/*---------------------------------------------------------------- + Value type boxing +----------------------------------------------------------------*/ + +void kk_valuetype_unbox_from_any(kk_box_t* p, size_t size, kk_box_t box, kk_borrow_t borrow, kk_context_t* ctx) { + const size_t max_scan_fsize = size / sizeof(kk_box_t); + for (size_t i = 0; i < max_scan_fsize; i++) { + p[i] = kk_box_any(ctx); + } + if (kk_is_owned(borrow)) { + kk_block_decref(kk_block_unbox(box, KK_TAG_BOX_ANY, ctx), ctx); + } +} /*---------------------------------------------------------------- Integer boxing @@ -17,121 +30,121 @@ typedef struct kk_boxed_intptr_s { intptr_t value; } *boxed_intptr_t; -intptr_t kk_intptr_unbox(kk_box_t v, kk_context_t* ctx) { - if (kk_likely(kk_box_is_value(v))) { +intptr_t kk_intptr_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { + if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); return (intptr_t)i; } else { - kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v)) == KK_TAG_INTPTR) || kk_box_is_any(v)); - boxed_intptr_t bi = kk_block_assert(boxed_intptr_t, kk_ptr_unbox(v), KK_TAG_INTPTR); + kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INTPTR) || kk_box_is_any(v)); + boxed_intptr_t bi = kk_block_assert(boxed_intptr_t, kk_ptr_unbox(v,ctx), KK_TAG_INTPTR); intptr_t i = bi->value; - if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } + if (kk_is_owned(borrow)) { kk_block_drop(&bi->_block, ctx); } return i; } } kk_box_t kk_intptr_box(intptr_t i, kk_context_t* ctx) { - if (i >= KK_MIN_BOXED_INT && i <= KK_MAX_BOXED_INT) { - return kk_intf_box(i); + if (i >= KK_INTF_BOX_MIN(0) && i <= KK_INTF_BOX_MAX(0)) { + return kk_intf_box((kk_intf_t)i); } else { boxed_intptr_t bi = kk_block_alloc_as(struct kk_boxed_intptr_s, 0, KK_TAG_INTPTR, ctx); bi->value = i; - return kk_ptr_box(&bi->_block); + return kk_ptr_box(&bi->_block,ctx); } } -#if (KK_INTPTR_SIZE <= 8) +#if (KK_INTF_SIZE <= 8) typedef struct kk_boxed_int64_s { kk_block_t _block; int64_t value; } *boxed_int64_t; -int64_t kk_int64_unbox(kk_box_t v, kk_context_t* ctx) { - if (kk_likely(kk_box_is_value(v))) { +int64_t kk_int64_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { + if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); return (int64_t)i; } else { - kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v)) == KK_TAG_INT64) || kk_box_is_any(v)); - boxed_int64_t bi = kk_block_assert(boxed_int64_t, kk_ptr_unbox(v), KK_TAG_INT64); + kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INT64) || kk_box_is_any(v)); + boxed_int64_t bi = kk_block_assert(boxed_int64_t, kk_ptr_unbox(v,ctx), KK_TAG_INT64); int64_t i = bi->value; - if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } + if (kk_is_owned(borrow)) { kk_block_drop(&bi->_block, ctx); } return i; } } kk_box_t kk_int64_box(int64_t i, kk_context_t* ctx) { - if (i >= KK_MIN_BOXED_INT && i <= KK_MAX_BOXED_INT) { + if (i >= KK_INTF_BOX_MIN(0) && i <= KK_INTF_BOX_MAX(0)) { return kk_intf_box((kk_intf_t)i); } else { boxed_int64_t bi = kk_block_alloc_as(struct kk_boxed_int64_s, 0, KK_TAG_INT64, ctx); bi->value = i; - return kk_ptr_box(&bi->_block); + return kk_ptr_box(&bi->_block,ctx); } } #endif -#if (KK_INTPTR_SIZE <= 4) +#if (KK_INTF_SIZE <= 4) typedef struct kk_boxed_int32_s { kk_block_t _block; int32_t value; } *boxed_int32_t; -int32_t kk_int32_unbox(kk_box_t v, kk_context_t* ctx) { - if (kk_likely(kk_box_is_value(v))) { +int32_t kk_int32_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { + if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); kk_assert_internal((i >= INT32_MIN && i <= INT32_MAX) || kk_box_is_any(v)); return (int32_t)i; } else { - kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v)) == KK_TAG_INT32) || kk_box_is_any(v)); - boxed_int32_t bi = kk_block_assert(boxed_int32_t, kk_ptr_unbox(v), KK_TAG_INT32); + kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INT32) || kk_box_is_any(v)); + boxed_int32_t bi = kk_block_assert(boxed_int32_t, kk_ptr_unbox(v,ctx), KK_TAG_INT32); int32_t i = bi->value; - if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } + if (kk_is_owned(borrow)) { kk_block_drop(&bi->_block, ctx); } return i; } } kk_box_t kk_int32_box(int32_t i, kk_context_t* ctx) { - if (i >= KK_MIN_BOXED_INT && i <= KK_MAX_BOXED_INT) { + if (i >= KK_INTF_BOX_MIN(0) && i <= KK_INTF_BOX_MAX(0)) { return kk_intf_box(i); } else { boxed_int32_t bi = kk_block_alloc_as(struct kk_boxed_int32_s, 0, KK_TAG_INT32, ctx); bi->value = i; - return kk_ptr_box(&bi->_block); + return kk_ptr_box(&bi->_block,ctx); } } #endif -#if (KK_INTPTR_SIZE <= 2) +#if (KK_INTF_SIZE <= 2) typedef struct kk_boxed_int16_s { kk_block_t _block; int16_t value; } *boxed_int16_t; -int16_t kk_int16_unbox(kk_box_t v, kk_context_t* ctx) { - if (kk_likely(kk_box_is_value(v))) { +int16_t kk_int16_unbox(kk_box_t v, kk_borrow_t borrow, kk_context_t* ctx) { + if kk_likely(kk_box_is_value(v)) { kk_intf_t i = kk_intf_unbox(v); kk_assert_internal((i >= int16_MIN && i <= int16_MAX) || kk_box_is_any(v)); return (int16_t)i; } else { - kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v)) == KK_TAG_INT16) || kk_box_is_any(v)); - boxed_int16_t bi = kk_block_assert(boxed_int16_t, kk_ptr_unbox(v), KK_TAG_INT16); + kk_assert_internal((kk_box_is_ptr(v) && kk_block_tag(kk_ptr_unbox(v,ctx)) == KK_TAG_INT16) || kk_box_is_any(v)); + boxed_int16_t bi = kk_block_assert(boxed_int16_t, kk_ptr_unbox(v,ctx), KK_TAG_INT16); int16_t i = bi->value; - if (ctx!=NULL) { kk_block_drop(&bi->_block, ctx); } + if (kk_is_owned(borrow)) { kk_block_drop(&bi->_block, ctx); } return i; } } kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx) { - if (i >= KK_MIN_BOXED_INT && i <= KK_MAX_BOXED_INT) { + if (i >= KK_INTF_BOX_MIN && i <= KK_INTF_BOX_MAX) { return kk_intf_box(i); } else { @@ -142,33 +155,33 @@ kk_box_t kk_int16_box(int16_t i, kk_context_t* ctx) { } #endif -#if KK_SSIZE_SIZE == KK_INTPTR_SIZE +#if KK_SSIZE_SIZE == KK_INTF_SIZE kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx) { return kk_intptr_box(i, ctx); } -kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx) { - return kk_intptr_unbox(b, ctx); +kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return kk_intptr_unbox(b, borrow, ctx); } #elif KK_SSIZE_SIZE == 8 kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx) { return kk_int64_box(i, ctx); } -kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx) { - return kk_int64_unbox(b, ctx); +kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return kk_int64_unbox(b, borrow, ctx); } #elif KK_SSIZE_SIZE == 4 kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx) { return kk_int32_box(i, ctx); } -kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx) { - return kk_int32_unbox(b, ctx); +kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return kk_int32_unbox(b, borrow, ctx); } #elif KK_SSIZE_SIZE == 2 kk_box_t kk_ssize_box(kk_ssize_t i, kk_context_t* ctx) { return kk_int16_box(i, ctx); } -kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_context_t* ctx) { - return kk_int16_unbox(b, ctx); +kk_ssize_t kk_ssize_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + return kk_int16_unbox(b, borrow, ctx); } #else #error "platform size_t must be 16, 32, 64, or 128 bits" @@ -185,19 +198,22 @@ kk_box_t kk_cptr_raw_box(kk_free_fun_t* freefun, void* p, kk_context_t* ctx) { kk_cptr_raw_t raw = kk_block_alloc_as(struct kk_cptr_raw_s, 0, KK_TAG_CPTR_RAW, ctx); raw->free = freefun; raw->cptr = p; - return kk_ptr_box(&raw->_block); + return kk_ptr_box(&raw->_block,ctx); } -void* kk_cptr_raw_unbox(kk_box_t b) { - kk_cptr_raw_t raw = kk_basetype_unbox_as_assert(kk_cptr_raw_t, b, KK_TAG_CPTR_RAW); - return raw->cptr; +// always assumed borrowed! If dropped here a C free routine may make the returned pointer invalid. +void* kk_cptr_raw_unbox_borrowed(kk_box_t b, kk_context_t* ctx) { + kk_cptr_raw_t raw = kk_block_unbox_as(kk_cptr_raw_t, b, KK_TAG_CPTR_RAW, ctx); + void* p = raw->cptr; + // if (kk_is_owned(borrow)) { kk_base_type_drop(raw, ctx); } + return p; } kk_box_t kk_cptr_box(void* p, kk_context_t* ctx) { - uintptr_t u = (uintptr_t)p; - if (kk_likely((u&1) == 0 && u <= KK_MAX_BOXED_UINT)) { // aligned pointer? + intptr_t i = (intptr_t)p; + if kk_likely(i >= KK_INTF_BOX_MIN(0) && i <= KK_INTF_BOX_MAX(0)) { // box as value - return _kk_box_new_value((kk_uintf_t)(u|1)); + return kk_intf_box((kk_intf_t)i); } else { // allocate @@ -205,56 +221,31 @@ kk_box_t kk_cptr_box(void* p, kk_context_t* ctx) { } } -void* kk_cptr_unbox(kk_box_t b) { +void* kk_cptr_unbox_borrowed(kk_box_t b, kk_context_t* ctx) { if (kk_box_is_value(b)) { - return (void*)(_kk_box_value(b) ^ 1); // clear lowest bit + return (void*)((intptr_t)kk_intf_unbox(b)); } else { - return kk_cptr_raw_unbox(b); + return kk_cptr_raw_unbox_borrowed(b,ctx); } } -// C Function pointers -kk_box_t kk_cfun_ptr_boxx(kk_cfun_ptr_t f, kk_context_t* ctx) { - uintptr_t u = (uintptr_t)f; // assume we can convert a function pointer to uintptr_t... - if ((u <= KK_MAX_BOXED_UINT) && sizeof(u)==sizeof(f)) { // aligned pointer? (and sanity check if function pointer != object pointer) - return kk_uintf_box(u); - } - else { - // otherwise allocate - kk_cfunptr_t fp = kk_block_alloc_as(struct kk_cfunptr_s, 0, KK_TAG_CFUNPTR, ctx); - fp->cfunptr = f; - return kk_ptr_box(&fp->_block); - } -} - -kk_cfun_ptr_t kk_cfun_ptr_unbox(kk_box_t b) { // never drop; only used from function call - if (kk_likely(kk_box_is_value(b))) { - return (kk_cfun_ptr_t)(kk_uintf_unbox(b)); - } - else { - kk_cfunptr_t fp = kk_basetype_unbox_as_assert(kk_cfunptr_t, b, KK_TAG_CFUNPTR); - kk_cfun_ptr_t f = fp->cfunptr; - return f; - } -} /*---------------------------------------------------------------- Maybe type support ----------------------------------------------------------------*/ -kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_context_t* ctx ) { +kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_borrow_t borrow, kk_context_t* ctx ) { kk_assert_internal(kk_block_has_tag(b,KK_TAG_JUST)); - kk_just_t* just = kk_block_as(kk_just_t*,b); - kk_box_t res = just->value; - if (ctx != NULL) { - if (kk_basetype_is_unique(just)) { - kk_basetype_free(just,ctx); + kk_box_t res = kk_block_as(kk_just_t*, b)->value; + if (kk_is_owned(borrow)) { + if (kk_block_is_unique(b)) { + kk_block_free(b,ctx); } else { - kk_box_dup(res); - kk_basetype_decref(just, ctx); + kk_box_dup(res,ctx); + kk_block_decref(b, ctx); } } return res; @@ -265,35 +256,34 @@ kk_box_t kk_unbox_Just_block( kk_block_t* b, kk_context_t* ctx ) { Double boxing on 64-bit systems ----------------------------------------------------------------*/ -#if (KK_INTPTR_SIZE == 8) && KK_BOX_DOUBLE64 +#if (KK_INTF_SIZE == 8) && KK_BOX_DOUBLE64 // Generic double allocation in the heap typedef struct kk_boxed_double_s { kk_block_t _block; double value; } *kk_boxed_double_t; -static double kk_double_unbox_heap(kk_box_t b, kk_context_t* ctx) { - kk_boxed_double_t dt = kk_block_assert(kk_boxed_double_t, kk_ptr_unbox(b), KK_TAG_DOUBLE); +static double kk_double_unbox_heap(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + kk_boxed_double_t dt = kk_block_assert(kk_boxed_double_t, kk_ptr_unbox(b,ctx), KK_TAG_DOUBLE); double d = dt->value; - if (ctx != NULL) { kk_basetype_drop(dt, ctx); } + if (kk_is_owned(borrow)) { kk_base_type_drop(dt, ctx); } return d; } static kk_box_t kk_double_box_heap(double d, kk_context_t* ctx) { kk_boxed_double_t dt = kk_block_alloc_as(struct kk_boxed_double_s, 0, KK_TAG_DOUBLE, ctx); dt->value = d; - return kk_ptr_box(&dt->_block); + return kk_ptr_box(&dt->_block, ctx); } #if (KK_BOX_DOUBLE64 == 2) // heap allocate when negative kk_box_t kk_double_box(double d, kk_context_t* ctx) { kk_unused(ctx); - uint64_t i = kk_bits_from_double(d); + uint64_t u = kk_bits_from_double(d); //if (isnan(d)) { kk_debugger_break(ctx); } - if ((int64_t)i >= 0) { // positive? - kk_box_t b = { ((uintptr_t)i<<1)|1 }; - return b; + if (u <= KK_UINTF_BOX_MAX) { // fits in a boxed value? (i.e. is the double positive) + return kk_uintf_box(u); } else { // heap allocate @@ -301,17 +291,16 @@ kk_box_t kk_double_box(double d, kk_context_t* ctx) { } } -double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { +double kk_double_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { kk_unused(ctx); double d; if (kk_box_is_value(b)) { // positive double - uint64_t u = kk_shrp(b.box, 1); - d = kk_bits_to_double(u); + d = kk_bits_to_double(kk_uintf_unbox(b)); } else { // heap allocated - d = kk_double_unbox_heap(b, ctx); + d = kk_double_unbox_heap(b, borrow, ctx); } // if (isnan(d)) { kk_debugger_break(ctx); } return d; @@ -338,18 +327,17 @@ kk_box_t kk_double_box(double d, kk_context_t* ctx) { return kk_double_box_heap(d, ctx); } kk_assert_internal(exp <= 0x3FF); - kk_box_t b = { (u | (exp<<1) | 1) }; - return b; + kk_assert_internal((kk_shr64(u,1) & 0x3FF) == 0); + return kk_uintf_box( kk_shr64(u,1) | exp ); } -double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { +double kk_double_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { kk_unused(ctx); if (kk_box_is_value(b)) { // expand 10-bit exponent to 11-bits again - uint64_t u = b.box; - uint64_t exp = u & 0x7FF; - u -= exp; // clear lower 11 bits - exp >>= 1; + uint64_t u = kk_uintf_unbox(b); + uint64_t exp = u & 0x3FF; + u -= exp; // clear lower 10 bits if (exp == 0) { // ok } @@ -360,13 +348,13 @@ double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { exp += 0x200; } kk_assert_internal(exp <= 0x7FF); - u = kk_bits_rotr64(u | exp, 12); + u = kk_bits_rotr64( kk_shl64(u,1) | exp, 12); double d = kk_bits_to_double(u); return d; } else { // heap allocated - return kk_double_unbox_heap(b, ctx); + return kk_double_unbox_heap(b, borrow, ctx); } } #endif @@ -377,32 +365,31 @@ double kk_double_unbox(kk_box_t b, kk_context_t* ctx) { Float boxing on 32-bit systems ----------------------------------------------------------------*/ -#if (KK_INTPTR_SIZE == 4) +#if (KK_INTF_SIZE == 4) // Generic float allocation in the heap typedef struct kk_boxed_float_s { kk_block_t _block; float value; } *kk_boxed_float_t; -static float kk_float_unbox_heap(kk_box_t b, kk_context_t* ctx) { - kk_boxed_float_t ft = kk_block_assert(kk_boxed_float_t, kk_ptr_unbox(b), KK_TAG_FLOAT); +static float kk_float_unbox_heap(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { + kk_boxed_float_t ft = kk_block_assert(kk_boxed_float_t, kk_ptr_unbox(b,ctx), KK_TAG_FLOAT); float f = ft->value; - if (ctx != NULL) { kk_basetype_drop(ft, ctx); } + if (kk_is_owned(borrow)) { kk_base_type_drop(ft, ctx); } return f; } static kk_box_t kk_float_box_heap(float f, kk_context_t* ctx) { kk_boxed_float_t ft = kk_block_alloc_as(struct kk_boxed_float_s, 0, KK_TAG_FLOAT, ctx); ft->value = f; - return kk_ptr_box(&ft->_block); + return kk_ptr_box(&ft->_block,ctx); } kk_box_t kk_float_box(float f, kk_context_t* ctx) { kk_unused(ctx); - uint32_t i = kk_bits_from_float(f); - if ((int32_t)i >= 0) { // positive? - kk_box_t b = { ((uintptr_t)i<<1)|1 }; - return b; + uint32_t u = kk_bits_from_float(f); + if (u <= KK_UINTF_BOX_MAX(0)) { // fits in a boxed value? (i.e. is the double positive) + return kk_uintf_box(u); } else { // heap allocate @@ -410,17 +397,16 @@ kk_box_t kk_float_box(float f, kk_context_t* ctx) { } } -float kk_float_unbox(kk_box_t b, kk_context_t* ctx) { +float kk_float_unbox(kk_box_t b, kk_borrow_t borrow, kk_context_t* ctx) { kk_unused(ctx); float f; if (kk_box_is_value(b)) { // positive float - uint32_t u = kk_shrp(b.box, 1); - f = kk_bits_to_float(u); + f = kk_bits_to_float(kk_uintf_unbox(b)); } else { // heap allocated - f = kk_float_unbox_heap(b, ctx); + f = kk_float_unbox_heap(b, borrow, ctx); } // if (isnan(f)) { kk_debugger_break(ctx); } return f; diff --git a/kklib/src/bytes.c b/kklib/src/bytes.c index 2846973f5..54ff73446 100644 --- a/kklib/src/bytes.c +++ b/kklib/src/bytes.c @@ -31,7 +31,7 @@ kk_decl_export kk_decl_noinline kk_bytes_t kk_bytes_alloc_len(kk_ssize_t len, kk } b->u.buf[len] = 0; if (buf != NULL) *buf = &b->u.buf[0]; - return kk_datatype_from_base(&b->_base); + return kk_datatype_from_base(&b->_base,ctx); } else { kk_bytes_normal_t b = kk_block_assert(kk_bytes_normal_t, kk_block_alloc_any(kk_ssizeof(struct kk_bytes_normal_s) - 1 /* char b[1] */ + len + 1 /* 0 terminator */, 0, KK_TAG_BYTES, ctx), KK_TAG_BYTES); @@ -42,7 +42,7 @@ kk_decl_export kk_decl_noinline kk_bytes_t kk_bytes_alloc_len(kk_ssize_t len, kk b->buf[len] = 0; if (buf != NULL) *buf = &b->buf[0]; // todo: kk_assert valid utf-8 in debug mode - return kk_datatype_from_base(&b->_base); + return kk_datatype_from_base(&b->_base,ctx); } } @@ -53,15 +53,15 @@ kk_bytes_t kk_bytes_adjust_length(kk_bytes_t b, kk_ssize_t newlen, kk_context_t* return kk_bytes_empty(); } kk_ssize_t len; - const uint8_t* s = kk_bytes_buf_borrow(b,&len); + const uint8_t* s = kk_bytes_buf_borrow(b,&len,ctx); if (len == newlen) { return b; } else if (len > newlen && (3*(len/4)) < newlen && // 0.75*len < newlen < len: update length in place if we can - kk_datatype_is_unique(b) && kk_datatype_has_tag(b, KK_TAG_BYTES)) { + kk_datatype_ptr_is_unique(b,ctx) && kk_datatype_ptr_has_tag(b, KK_TAG_BYTES, ctx)) { // length in place - kk_assert_internal(kk_datatype_has_tag(b, KK_TAG_BYTES) && kk_datatype_is_unique(b)); - kk_bytes_normal_t nb = kk_datatype_as_assert(kk_bytes_normal_t, b, KK_TAG_BYTES); + kk_assert_internal(kk_datatype_has_tag(b, KK_TAG_BYTES,ctx) && kk_datatype_ptr_is_unique(b,ctx)); + kk_bytes_normal_t nb = kk_datatype_as_assert(kk_bytes_normal_t, b, KK_TAG_BYTES, ctx); nb->length = newlen; nb->buf[newlen] = 0; // kk_assert_internal(kk_bytes_is_valid(kk_bytes_dup(s),ctx)); @@ -101,12 +101,12 @@ const uint8_t* kk_memmem(const uint8_t* p, kk_ssize_t plen, const uint8_t* pat, return NULL; } -int kk_bytes_cmp_borrow(kk_bytes_t b1, kk_bytes_t b2) { +int kk_bytes_cmp_borrow(kk_bytes_t b1, kk_bytes_t b2, kk_context_t* ctx) { if (kk_bytes_ptr_eq_borrow(b1, b2)) return 0; kk_ssize_t len1; - const uint8_t* s1 = kk_bytes_buf_borrow(b1,&len1); + const uint8_t* s1 = kk_bytes_buf_borrow(b1,&len1,ctx); kk_ssize_t len2; - const uint8_t* s2 = kk_bytes_buf_borrow(b2,&len2); + const uint8_t* s2 = kk_bytes_buf_borrow(b2,&len2,ctx); kk_ssize_t minlen = (len1 <= len2 ? len1 : len2); int ord = kk_memcmp(s1, s2, minlen); if (ord == 0) { @@ -117,7 +117,7 @@ int kk_bytes_cmp_borrow(kk_bytes_t b1, kk_bytes_t b2) { } int kk_bytes_cmp(kk_bytes_t b1, kk_bytes_t b2, kk_context_t* ctx) { - int ord = kk_bytes_cmp_borrow(b1,b2); + int ord = kk_bytes_cmp_borrow(b1,b2,ctx); kk_bytes_drop(b1,ctx); kk_bytes_drop(b2,ctx); return ord; @@ -128,12 +128,12 @@ int kk_bytes_cmp(kk_bytes_t b1, kk_bytes_t b2, kk_context_t* ctx) { Utilities --------------------------------------------------------------------------------------------------*/ -kk_ssize_t kk_decl_pure kk_bytes_count_pattern_borrow(kk_bytes_t b, kk_bytes_t pattern) { +kk_ssize_t kk_decl_pure kk_bytes_count_pattern_borrow(kk_bytes_t b, kk_bytes_t pattern, kk_context_t* ctx) { kk_ssize_t patlen; - const uint8_t* pat = kk_bytes_buf_borrow(pattern,&patlen); + const uint8_t* pat = kk_bytes_buf_borrow(pattern,&patlen,ctx); kk_ssize_t len; - const uint8_t* s = kk_bytes_buf_borrow(b,&len); - if (patlen <= 0) return kk_bytes_len_borrow(b); + const uint8_t* s = kk_bytes_buf_borrow(b,&len,ctx); + if (patlen <= 0) return kk_bytes_len_borrow(b,ctx); if (patlen > len) return 0; //todo: optimize by doing backward Boyer-Moore? or use forward Knuth-Morris-Pratt? @@ -151,9 +151,9 @@ kk_ssize_t kk_decl_pure kk_bytes_count_pattern_borrow(kk_bytes_t b, kk_bytes_t p kk_bytes_t kk_bytes_cat(kk_bytes_t b1, kk_bytes_t b2, kk_context_t* ctx) { kk_ssize_t len1; - const uint8_t* s1 = kk_bytes_buf_borrow(b1, &len1); + const uint8_t* s1 = kk_bytes_buf_borrow(b1, &len1, ctx); kk_ssize_t len2; - const uint8_t* s2 = kk_bytes_buf_borrow(b2, &len2); + const uint8_t* s2 = kk_bytes_buf_borrow(b2, &len2, ctx); uint8_t* p; kk_bytes_t t = kk_bytes_alloc_buf(len1 + len2, &p, ctx ); kk_memcpy(p, s1, len1); @@ -167,7 +167,7 @@ kk_bytes_t kk_bytes_cat(kk_bytes_t b1, kk_bytes_t b2, kk_context_t* ctx) { kk_bytes_t kk_bytes_cat_from_buf(kk_bytes_t b1, kk_ssize_t len2, const uint8_t* b2, kk_context_t* ctx) { if (b2 == NULL || len2 <= 0) return b1; kk_ssize_t len1; - const uint8_t* s1 = kk_bytes_buf_borrow(b1,&len1); + const uint8_t* s1 = kk_bytes_buf_borrow(b1,&len1,ctx); uint8_t* p; kk_bytes_t t = kk_bytes_alloc_buf(len1 + len2, &p, ctx); kk_memcpy(p, s1, len1); @@ -185,10 +185,10 @@ kk_vector_t kk_bytes_splitv_atmost(kk_bytes_t b, kk_bytes_t sepb, kk_ssize_t n, { if (n < 1) n = 1; kk_ssize_t len; - const uint8_t* s = kk_bytes_buf_borrow(b, &len); + const uint8_t* s = kk_bytes_buf_borrow(b, &len, ctx); const uint8_t* const end = s + len; kk_ssize_t seplen; - const uint8_t* sep = kk_bytes_buf_borrow(sepb, &seplen); + const uint8_t* sep = kk_bytes_buf_borrow(sepb, &seplen, ctx); // count parts kk_ssize_t count = 1; @@ -235,19 +235,19 @@ kk_bytes_t kk_bytes_replace_all(kk_bytes_t s, kk_bytes_t pat, kk_bytes_t rep, kk kk_bytes_t kk_bytes_replace_atmost(kk_bytes_t s, kk_bytes_t pat, kk_bytes_t rep, kk_ssize_t n, kk_context_t* ctx) { kk_bytes_t t = s; - if (!(n<=0 || kk_bytes_is_empty_borrow(s) || kk_bytes_is_empty_borrow(pat))) + if (!(n<=0 || kk_bytes_is_empty_borrow(s, ctx) || kk_bytes_is_empty_borrow(pat, ctx))) { kk_ssize_t plen; - const uint8_t* p = kk_bytes_buf_borrow(s,&plen); + const uint8_t* p = kk_bytes_buf_borrow(s,&plen,ctx); kk_ssize_t ppat_len; - const uint8_t* ppat = kk_bytes_buf_borrow(pat,&ppat_len); + const uint8_t* ppat = kk_bytes_buf_borrow(pat,&ppat_len,ctx); kk_ssize_t prep_len; - const uint8_t* prep = kk_bytes_buf_borrow(rep, &prep_len); + const uint8_t* prep = kk_bytes_buf_borrow(rep, &prep_len,ctx); const uint8_t* const pend = p + plen; // if unique s && |rep| == |pat|, update in-place // TODO: if unique s & |rep| <= |pat|, maybe update in-place if not too much waste? - if (kk_datatype_is_unique(s) && ppat_len == prep_len) { + if (kk_datatype_ptr_is_unique(s,ctx) && ppat_len == prep_len) { kk_ssize_t count = 0; while (count < n && p < pend) { const uint8_t* r = kk_memmem(p, pend - p, ppat, ppat_len); @@ -283,7 +283,7 @@ kk_bytes_t kk_bytes_replace_atmost(kk_bytes_t s, kk_bytes_t pat, kk_bytes_t rep, } kk_ssize_t rest = (pend - p); kk_memcpy(q, p, rest); - kk_assert_internal(q + rest == kk_bytes_buf_borrow(t,NULL) + newlen); + kk_assert_internal(q + rest == kk_bytes_buf_borrow(t,NULL,ctx) + newlen); } } @@ -297,7 +297,7 @@ kk_bytes_t kk_bytes_replace_atmost(kk_bytes_t s, kk_bytes_t pat, kk_bytes_t rep, kk_bytes_t kk_bytes_repeat(kk_bytes_t b, kk_ssize_t n, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_bytes_buf_borrow(b,&len); + const uint8_t* s = kk_bytes_buf_borrow(b,&len,ctx); if (len <= 0 || n<=0) return kk_bytes_empty(); uint8_t* t; kk_bytes_t tb = kk_bytes_alloc_buf(len*n, &t, ctx); // TODO: check overflow @@ -319,9 +319,9 @@ kk_bytes_t kk_bytes_repeat(kk_bytes_t b, kk_ssize_t n, kk_context_t* ctx) { // to avoid casting to signed, return 0 for not found, or the index+1 kk_ssize_t kk_bytes_index_of1(kk_bytes_t b, kk_bytes_t sub, kk_context_t* ctx) { kk_ssize_t slen; - const uint8_t* s = kk_bytes_buf_borrow(b, &slen); + const uint8_t* s = kk_bytes_buf_borrow(b, &slen,ctx); kk_ssize_t tlen; - const uint8_t* t = kk_bytes_buf_borrow(sub, &tlen); + const uint8_t* t = kk_bytes_buf_borrow(sub, &tlen,ctx); kk_ssize_t idx; if (tlen <= 0) { idx = (slen <= 0 ? 0 : 1); @@ -340,9 +340,9 @@ kk_ssize_t kk_bytes_index_of1(kk_bytes_t b, kk_bytes_t sub, kk_context_t* ctx) { kk_ssize_t kk_bytes_last_index_of1(kk_bytes_t b, kk_bytes_t sub, kk_context_t* ctx) { kk_ssize_t slen; - const uint8_t* s = kk_bytes_buf_borrow(b, &slen); + const uint8_t* s = kk_bytes_buf_borrow(b, &slen,ctx); kk_ssize_t tlen; - const uint8_t* t = kk_bytes_buf_borrow(sub, &tlen); + const uint8_t* t = kk_bytes_buf_borrow(sub, &tlen,ctx); kk_ssize_t idx; if (tlen <= 0) { idx = slen; @@ -351,7 +351,7 @@ kk_ssize_t kk_bytes_last_index_of1(kk_bytes_t b, kk_bytes_t sub, kk_context_t* c idx = 0; } else if (tlen == slen) { - idx = (kk_bytes_cmp_borrow(b, sub) == 0 ? 1 : 0); + idx = (kk_bytes_cmp_borrow(b, sub,ctx) == 0 ? 1 : 0); } else { const uint8_t* p; @@ -367,9 +367,9 @@ kk_ssize_t kk_bytes_last_index_of1(kk_bytes_t b, kk_bytes_t sub, kk_context_t* c bool kk_bytes_starts_with(kk_bytes_t b, kk_bytes_t pre, kk_context_t* ctx) { kk_ssize_t slen; - const uint8_t* s = kk_bytes_buf_borrow(b, &slen); + const uint8_t* s = kk_bytes_buf_borrow(b, &slen,ctx); kk_ssize_t tlen; - const uint8_t* t = kk_bytes_buf_borrow(pre, &tlen); + const uint8_t* t = kk_bytes_buf_borrow(pre, &tlen,ctx); bool starts; if (tlen <= 0) { starts = (slen > 0); @@ -387,9 +387,9 @@ bool kk_bytes_starts_with(kk_bytes_t b, kk_bytes_t pre, kk_context_t* ctx) { bool kk_bytes_ends_with(kk_bytes_t b, kk_bytes_t post, kk_context_t* ctx) { kk_ssize_t slen; - const uint8_t* s = kk_bytes_buf_borrow(b, &slen); + const uint8_t* s = kk_bytes_buf_borrow(b, &slen, ctx); kk_ssize_t tlen; - const uint8_t* t = kk_bytes_buf_borrow(post, &tlen); + const uint8_t* t = kk_bytes_buf_borrow(post, &tlen, ctx); bool ends; if (tlen <= 0) { ends = (slen > 0); diff --git a/kklib/src/init.c b/kklib/src/init.c index 7dd417f0f..80a3d6883 100644 --- a/kklib/src/init.c +++ b/kklib/src/init.c @@ -7,6 +7,8 @@ ---------------------------------------------------------------------------*/ //#define _CRT_SECURE_NO_WARNINGS #include "kklib.h" +#include "kklib/os.h" // kk_timer_now + #include #include #ifdef WIN32 @@ -21,18 +23,24 @@ static kk_box_t _function_id(kk_function_t self, kk_box_t x, kk_context_t* ctx) } kk_function_t kk_function_id(kk_context_t* ctx) { kk_define_static_function(fun_id, _function_id, ctx) - return kk_function_dup(fun_id); + return kk_function_dup(fun_id,ctx); } // null function static kk_box_t _function_null(kk_function_t self, kk_context_t* ctx) { kk_function_drop(self, ctx); kk_fatal_error(EFAULT, "null function is called"); - return kk_box_null; + return kk_box_null(); } kk_function_t kk_function_null(kk_context_t* ctx) { kk_define_static_function(fun_null, _function_null, ctx) - return kk_function_dup(fun_null); + return kk_function_dup(fun_null,ctx); +} +bool kk_function_is_null(kk_function_t f, kk_context_t* ctx) { + kk_function_t fnull = kk_function_null(ctx); + bool eq = kk_datatype_eq(f, fnull); + kk_function_drop(fnull, ctx); + return eq; } @@ -53,8 +61,8 @@ void kk_free_fun(void* p, kk_block_t* b, kk_context_t* ctx) { kk_string_t kk_get_host(kk_context_t* ctx) { kk_unused(ctx); - kk_define_string_literal(static, host, 5, "libc") - return kk_string_dup(host); + kk_define_string_literal(static, host, 5, "libc", ctx); + return kk_string_dup(host,ctx); } /*-------------------------------------------------------------------------------------------------- @@ -133,11 +141,26 @@ void kk_info_message(const char* fmt, ...) { va_end(args); } +void kk_unsupported_external(const char* msg) { + kk_fatal_error(ENOSYS, "unsupported external: %s", msg); +} + /*-------------------------------------------------------------------------------------------------- Process init/done --------------------------------------------------------------------------------------------------*/ static bool process_initialized; // = false +#if KK_COMPRESS && (KK_INTB_SIZE==4 || KK_CHERI) + #if defined(KK_MIMALLOC) + #define KK_USE_MEM_ARENA 1 + static mi_arena_id_t arena; + static void* arena_start; + static size_t arena_size; + #else + #error "can only use compressed heaps with the mimalloc allocator enabled" + #endif +#endif + static void kklib_done(void) { if (!process_initialized) return; kk_free_context(); @@ -175,6 +198,21 @@ static void kklib_init(void) { kk_has_tzcnt = ((cpu_info[1] & (KK_I32(1)<<3)) != 0); // bmi1: https://en.wikipedia.org/wiki/X86_Bit_manipulation_instruction_set #endif atexit(&kklib_done); + + #if KK_USE_MEM_ARENA + #if (KK_INTB_SIZE==4) + const kk_ssize_t heap_size = kk_shlp(KK_IZ(1), KK_INTB_BITS + KK_BOX_PTR_SHIFT); // 16GiB + #elif KK_CHERI && (KK_INTB_SIZE==8) + const kk_ssize_t heap_size = 128 * KK_GiB; // todo: parameterize? + #else + #error "define heap initialization for compressed pointers on this platform" + #endif + int err = mi_reserve_os_memory_ex(heap_size, false /* commit */, true /* allow large */, true /*exclusive*/, &arena); + if (err != 0) { + kk_fatal_error(err, "unable to reserve the initial heap of %zi bytes", heap_size); + } + arena_start = mi_arena_area(arena, &arena_size); + #endif } /*-------------------------------------------------------------------------------------------------- @@ -184,38 +222,66 @@ static void kklib_init(void) { // The thread local context; usually passed explicitly for efficiency. static kk_decl_thread kk_context_t* context; - static struct { kk_block_t _block; kk_integer_t cfc; } kk_evv_empty_static = { - { KK_HEADER_STATIC(1,KK_TAG_EVV_VECTOR) }, { ((~KK_UP(0))^0x02) /*==-1 smallint*/} + { KK_HEADER_STATIC(1,KK_TAG_EVV_VECTOR) }, { ((~KK_UB(0))^0x02) /*==-1 smallint*/} +}; + +struct kk_evv_s { + kk_block_t _block; + kk_integer_t cfc; }; -kk_ptr_t kk_evv_empty_singleton = &kk_evv_empty_static._block; + +kk_datatype_ptr_t kk_evv_empty_singleton(kk_context_t* ctx) { + static struct kk_evv_s* evv = NULL; + if (evv == NULL) { + evv = kk_block_alloc_as(struct kk_evv_s, 1, KK_TAG_EVV_VECTOR, ctx); + evv->cfc = kk_integer_from_small(-1); + } + kk_base_type_dup_as(struct kk_evv_s*, evv); + return kk_datatype_from_base(evv, ctx); +} + // Get the thread local context (also initializes on demand) kk_context_t* kk_get_context(void) { kk_context_t* ctx = context; if (ctx!=NULL) return ctx; kklib_init(); -#ifdef KK_MIMALLOC +#if KK_USE_MEM_ARENA + kk_assert_internal(arena != 0 && arena_start != NULL); + mi_heap_t* heap = mi_heap_new_in_arena(arena); + ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); + kk_assign_const(kk_heap_t,ctx->heap) = heap; + kk_assign_const(void*, ctx->heap_start) = arena_start; + kk_addr_t arena_start_addr; + #if KK_CHERI + arena_start_addr = __builtin_cheri_address_get(arena_start); + #else + arena_start_addr = (kk_addr_t)arena_start; + #endif + kk_assign_const(kk_addr_t, ctx->heap_mid) = arena_start_addr + (kk_addr_t)(arena_size / 2); +#elif defined(KK_MIMALLOC) mi_heap_t* heap = mi_heap_get_default(); // mi_heap_new(); ctx = (kk_context_t*)mi_heap_zalloc(heap, sizeof(kk_context_t)); - ctx->heap = heap; + kk_assign_const(kk_heap_t, ctx->heap) = heap; #else - ctx = (kk_context_t*)kk_zalloc(sizeof(kk_context_t),NULL); + ctx = (kk_context_t*)kk_zalloc(sizeof(kk_context_t), NULL); #endif - ctx->evv = kk_block_dup(kk_evv_empty_singleton); ctx->thread_id = (size_t)(&context); ctx->unique = kk_integer_one; context = ctx; - ctx->kk_box_any = kk_block_alloc_as(struct kk_box_any_s, 0, KK_TAG_BOX_ANY, ctx); - ctx->kk_box_any->_unused = kk_integer_zero; + struct kk_box_any_s* boxany = kk_block_alloc_as(struct kk_box_any_s, 0, KK_TAG_BOX_ANY, ctx); + boxany->_unused = kk_integer_zero; + ctx->kk_box_any = kk_datatype_from_base(boxany, ctx); + ctx->evv = kk_evv_empty_singleton(ctx); // todo: register a thread_done function to release the context on thread terminatation. return ctx; } void kk_free_context(void) { if (context != NULL) { - kk_block_drop(context->evv, context); - kk_basetype_free(context->kk_box_any,context); + kk_datatype_ptr_drop(context->evv, context); + kk_datatype_ptr_free(context->kk_box_any,context); // kk_basetype_drop_assert(context->kk_box_any, KK_TAG_BOX_ANY, context); // TODO: process delayed_free #ifdef KK_MIMALLOC @@ -232,6 +298,7 @@ void kk_free_context(void) { /*-------------------------------------------------------------------------------------------------- Called from main --------------------------------------------------------------------------------------------------*/ +static bool kk_showtime; // false kk_decl_export kk_context_t* kk_main_start(int argc, char** argv) { kk_context_t* ctx = kk_get_context(); @@ -241,7 +308,8 @@ kk_decl_export kk_context_t* kk_main_start(int argc, char** argv) { for (i = 1; i < argc; i++) { // argv[0] is the program name const char* arg = argv[i]; if (strcmp(arg, "--kktime")==0) { - ctx->process_start = kk_timer_start(); + kk_showtime = true; + ctx->process_start = kk_timer_ticks(ctx); } else { break; @@ -258,8 +326,8 @@ kk_decl_export kk_context_t* kk_main_start(int argc, char** argv) { } kk_decl_export void kk_main_end(kk_context_t* ctx) { - if (ctx->process_start != 0) { // started with --kktime option - kk_usecs_t wall_time = kk_timer_end(ctx->process_start); + if (kk_showtime) { // started with --kktime option + kk_duration_t wall_time = kk_duration_sub(kk_timer_ticks(ctx), ctx->process_start); kk_msecs_t user_time; kk_msecs_t sys_time; size_t peak_rss; @@ -267,8 +335,8 @@ kk_decl_export void kk_main_end(kk_context_t* ctx) { size_t page_reclaim; size_t peak_commit; kk_process_info(&user_time, &sys_time, &peak_rss, &page_faults, &page_reclaim, &peak_commit); - kk_info_message("elapsed: %ld.%03lds, user: %ld.%03lds, sys: %ld.%03lds, rss: %lu%s\n", - (long)(wall_time/1000000), (long)((wall_time%1000000)/1000), + kk_info_message("elapsed: %" PRId64 ".%03lds, user: %ld.%03lds, sys : %ld.%03lds, rss : %lu%s\n", + wall_time.seconds, (long)(wall_time.attoseconds / (KK_I64(1000000) * KK_I64(1000000000))), user_time/1000, user_time%1000, sys_time/1000, sys_time%1000, (peak_rss > 10*1024*1024 ? peak_rss/(1024*1024) : peak_rss/1024), (peak_rss > 10*1024*1024 ? "mb" : "kb") ); diff --git a/kklib/src/integer.c b/kklib/src/integer.c index d27e25d02..fd94c8893 100644 --- a/kklib/src/integer.c +++ b/kklib/src/integer.c @@ -187,10 +187,11 @@ static kk_ptr_t bigint_ptr_(kk_bigint_t* x) { return &x->_block; } -static kk_integer_t bigint_as_integer_(kk_bigint_t* x) { - uintptr_t p = (uintptr_t)bigint_ptr_(x); - kk_assert_internal((p&3) == 0); - kk_integer_t i = { p }; +static kk_integer_t bigint_as_integer_(kk_bigint_t* x, kk_context_t* ctx) { + kk_integer_t i = { kk_ptr_encode(bigint_ptr_(x), ctx) }; +#if KK_TAG_VALUE!=KK_TAG_VALUE + i.ibox = i.ibox ^ 1; +#endif return i; } @@ -198,12 +199,13 @@ static bool bigint_is_unique_(kk_bigint_t* x) { return kk_block_is_unique(bigint_ptr_(x)); } -static kk_bigint_t* dup_bigint(kk_bigint_t* x) { - return kk_basetype_dup_as(kk_bigint_t*, x); +static kk_bigint_t* dup_bigint(kk_bigint_t* x, kk_context_t* ctx) { + kk_unused(ctx); + return kk_block_assert(kk_bigint_t*, kk_block_dup(&x->_block), KK_TAG_BIGINT); } static void drop_bigint(kk_bigint_t* x, kk_context_t* ctx) { - kk_basetype_drop(x,ctx); + kk_block_drop_assert(&x->_block,KK_TAG_BIGINT,ctx); } @@ -221,7 +223,7 @@ static kk_bigint_t* bigint_alloc(kk_ssize_t count, bool is_neg, kk_context_t* ct b->count = count; return b; } - + static kk_bigint_t* bigint_alloc_zero(kk_ssize_t count, bool is_neg, kk_context_t* ctx) { kk_bigint_t* b = bigint_alloc(count, is_neg, ctx); kk_memset(b->digits, 0, kk_ssizeof(kk_digit_t)* bigint_available_(b)); @@ -330,7 +332,7 @@ static kk_integer_t integer_bigint(kk_bigint_t* x, kk_context_t* ctx) { return kk_integer_from_small(i); } else { - return bigint_as_integer_(x); + return bigint_as_integer_(x,ctx); } } @@ -341,7 +343,7 @@ static kk_bigint_t* bigint_from_int(kk_intx_t i, kk_context_t* ctx) { u = (kk_uintx_t)i; } else if (i == KK_INTX_MIN) { - u = (KK_UINTX_MAX/2) + KK_UX(1); + u = KK_INTX_MAX; u++; // avoid compiler warning on msvc } else { u = (kk_uintx_t)(-i); @@ -361,7 +363,7 @@ static kk_bigint_t* bigint_from_int64(int64_t i, kk_context_t* ctx) { u = (uint64_t)i; } else if (i == INT64_MIN) { - u = (UINT64_MAX/2) + KK_U64(1); + u = INT64_MAX; u++; // avoid compiler warning on msvc } else { u = (uint64_t)(-i); @@ -389,7 +391,7 @@ static kk_bigint_t* bigint_from_uint64(uint64_t i, kk_context_t* ctx) { static kk_bigint_t* kk_integer_to_bigint(kk_integer_t x, kk_context_t* ctx) { kk_assert_internal(kk_is_integer(x)); if (kk_is_bigint(x)) { - return kk_block_assert(kk_bigint_t*, _kk_integer_ptr(x), KK_TAG_BIGINT); + return kk_block_assert(kk_bigint_t*, _kk_integer_ptr(x,ctx), KK_TAG_BIGINT); } else { kk_assert_internal(kk_is_smallint(x)); @@ -398,15 +400,15 @@ static kk_bigint_t* kk_integer_to_bigint(kk_integer_t x, kk_context_t* ctx) { } kk_integer_t kk_integer_from_bigu64(uint64_t i, kk_context_t* ctx) { - return bigint_as_integer_(bigint_from_uint64(i, ctx)); + return bigint_as_integer_(bigint_from_uint64(i, ctx),ctx); } kk_integer_t kk_integer_from_big64(int64_t i, kk_context_t* ctx) { - return bigint_as_integer_(bigint_from_int64(i,ctx)); + return bigint_as_integer_(bigint_from_int64(i,ctx),ctx); } kk_integer_t kk_integer_from_big(kk_intx_t i, kk_context_t* ctx) { - return bigint_as_integer_(bigint_from_int(i, ctx)); + return bigint_as_integer_(bigint_from_int(i, ctx),ctx); } @@ -746,7 +748,7 @@ bool kk_integer_hex_parse(const char* s, kk_integer_t* res, kk_context_t* ctx) { static kk_bigint_t* bigint_neg(kk_bigint_t* x, kk_context_t* ctx) { kk_bigint_t* z = bigint_ensure_unique(x,ctx); - z->is_neg = !z->is_neg; + z->is_neg = (z->is_neg == 0); return z; } @@ -800,7 +802,7 @@ static kk_bigint_t* bigint_add_abs(kk_bigint_t* x, kk_bigint_t* y, kk_context_t* kk_ssize_t i; for (i = 0; i < cy; i++) { sum = x->digits[i] + y->digits[i] + carry; - if (kk_unlikely(sum >= BASE)) { + if kk_unlikely(sum >= BASE) { carry = 1; sum -= BASE; } @@ -812,7 +814,7 @@ static kk_bigint_t* bigint_add_abs(kk_bigint_t* x, kk_bigint_t* y, kk_context_t* // propagate the carry for (; carry != 0 && i < cx; i++) { sum = x->digits[i] + carry; - if (kk_unlikely(sum >= BASE)) { + if kk_unlikely(sum >= BASE) { kk_assert_internal(sum==BASE && carry==1); // can only be at most BASE // carry stays 1; sum -= BASE; @@ -858,7 +860,7 @@ static kk_bigint_t* kk_bigint_add_abs_small(kk_bigint_t* x, kk_digit_t y, kk_con kk_ssize_t i; for (i = 0; carry!=0 && i < cx; i++) { sum = x->digits[i] + carry; - if (kk_unlikely(sum >= BASE)) { + if kk_unlikely(sum >= BASE) { carry = 1; sum -= BASE; kk_assert_internal(sum < BASE); @@ -912,7 +914,7 @@ static kk_bigint_t* kk_bigint_sub_abs(kk_bigint_t* x, kk_bigint_t* y, kk_context kk_ssize_t i; for (i = 0; i < cy; i++) { diff = x->digits[i] - borrow - y->digits[i]; - if (kk_unlikely(diff >= BASE)) { // unsigned wrap around + if kk_unlikely(diff >= BASE) { // unsigned wrap around borrow = 1; diff += BASE; // kk_assert_internal(diff >= 0); } @@ -924,7 +926,7 @@ static kk_bigint_t* kk_bigint_sub_abs(kk_bigint_t* x, kk_bigint_t* y, kk_context // propagate borrow for (; borrow != 0 && i < cx; i++) { diff = x->digits[i] - borrow; - if (kk_unlikely(diff >= BASE)) { // unsigned wrap around + if kk_unlikely(diff >= BASE) { // unsigned wrap around // borrow stays 1; kk_assert_internal(diff==~((kk_digit_t)0)); diff += BASE; @@ -999,7 +1001,7 @@ static kk_bigint_t* kk_bigint_mul_small(kk_bigint_t* x, kk_digit_t y, kk_context } static kk_bigint_t* kk_bigint_sqr(kk_bigint_t* x, kk_context_t* ctx) { - dup_bigint(x); + dup_bigint(x,ctx); return bigint_mul(x, x, ctx); } @@ -1036,17 +1038,17 @@ static kk_bigint_t* bigint_mul_karatsuba(kk_bigint_t* x, kk_bigint_t* y, kk_cont if (n <= 25) return bigint_mul(x, y, ctx); n = ((n + 1) / 2); - kk_bigint_t* b = kk_bigint_slice(dup_bigint(x), n, x->count, ctx); + kk_bigint_t* b = kk_bigint_slice(dup_bigint(x,ctx), n, x->count, ctx); kk_bigint_t* a = kk_bigint_slice(x, 0, n, ctx); - kk_bigint_t* d = kk_bigint_slice(dup_bigint(y), n, y->count, ctx); + kk_bigint_t* d = kk_bigint_slice(dup_bigint(y, ctx), n, y->count, ctx); kk_bigint_t* c = kk_bigint_slice(y, 0, n, ctx); - kk_bigint_t* ac = bigint_mul_karatsuba(dup_bigint(a), dup_bigint(c), ctx); - kk_bigint_t* bd = bigint_mul_karatsuba(dup_bigint(b), dup_bigint(d), ctx); + kk_bigint_t* ac = bigint_mul_karatsuba(dup_bigint(a, ctx), dup_bigint(c, ctx), ctx); + kk_bigint_t* bd = bigint_mul_karatsuba(dup_bigint(b, ctx), dup_bigint(d, ctx), ctx); kk_bigint_t* abcd = bigint_mul_karatsuba( bigint_add(a, b, b->is_neg, ctx), bigint_add(c, d, d->is_neg, ctx), ctx); - kk_bigint_t* p1 = kk_bigint_shift_left(kk_bigint_sub(kk_bigint_sub(abcd, dup_bigint(ac), ac->is_neg, ctx), - dup_bigint(bd), bd->is_neg, ctx), n, ctx); + kk_bigint_t* p1 = kk_bigint_shift_left(kk_bigint_sub(kk_bigint_sub(abcd, dup_bigint(ac, ctx), ac->is_neg, ctx), + dup_bigint(bd, ctx), bd->is_neg, ctx), n, ctx); kk_bigint_t* p2 = kk_bigint_shift_left(bd, 2 * n, ctx); kk_bigint_t* prod = bigint_add(bigint_add(ac, p1, p1->is_neg, ctx), p2, p2->is_neg, ctx); return kk_bigint_trim(prod,true, ctx); @@ -1072,15 +1074,15 @@ kk_integer_t kk_integer_pow(kk_integer_t x, kk_integer_t p, kk_context_t* ctx) { return (kk_integer_is_even(p,ctx) ? kk_integer_one : kk_integer_min_one); } } - if (kk_integer_signum_borrow(p)==-1) { + if (kk_integer_signum_borrow(p,ctx)==-1) { kk_integer_drop(p,ctx); return kk_integer_zero; } kk_integer_t y = kk_integer_one; if (kk_is_bigint(p)) { while (1) { - kk_integer_dup(p); + kk_integer_dup(p, ctx); if (kk_integer_is_odd(p,ctx)) { - kk_integer_dup(x); + kk_integer_dup(x, ctx); y = kk_integer_mul(y, x, ctx); p = kk_integer_dec(p, ctx); } @@ -1093,7 +1095,7 @@ kk_integer_t kk_integer_pow(kk_integer_t x, kk_integer_t p, kk_context_t* ctx) { kk_intx_t i = kk_smallint_from_integer(p); while (1) { if ((i&1)!=0) { - kk_integer_dup(x); + kk_integer_dup(x, ctx); y = kk_integer_mul(y, x, ctx); i--; } @@ -1259,9 +1261,9 @@ kk_integer_t kk_integer_sqr_generic(kk_integer_t x, kk_context_t* ctx) { } /* borrow x, may produce an invalid read if x is not a bigint */ -int kk_integer_signum_generic_bigint(kk_integer_t x) { +int kk_integer_signum_generic_bigint(kk_integer_t x, kk_context_t* ctx) { kk_assert_internal(kk_is_integer(x)); - kk_bigint_t* bx = kk_block_assert(kk_bigint_t*, _kk_integer_ptr(x), KK_TAG_BIGINT); + kk_bigint_t* bx = kk_block_assert(kk_bigint_t*, _kk_integer_ptr(x, ctx), KK_TAG_BIGINT); int signum = (bx->is_neg ? -1 : ((bx->count==0 && bx->digits[0]==0) ? 0 : 1)); return signum; } @@ -1285,7 +1287,7 @@ int kk_integer_cmp_generic(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { } int kk_integer_cmp_generic_borrow(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - return kk_integer_cmp_generic(kk_integer_dup(x), kk_integer_dup(y), ctx); + return kk_integer_cmp_generic(kk_integer_dup(x, ctx), kk_integer_dup(y, ctx), ctx); } kk_integer_t kk_integer_add_generic(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { @@ -1363,7 +1365,7 @@ kk_integer_t kk_integer_cdiv_cmod_generic(kk_integer_t x, kk_integer_t y, kk_int } if (cmp==0) { if (mod) *mod = kk_integer_zero; - kk_intx_t i = (bigint_is_neg_(bx) == bigint_is_neg_(by) ? 1 : -1); + kk_intf_t i = (bigint_is_neg_(bx) == bigint_is_neg_(by) ? 1 : -1); kk_integer_drop(x, ctx); kk_integer_drop(y, ctx); return kk_integer_from_small(i); @@ -1410,25 +1412,25 @@ kk_integer_t kk_integer_div_mod_generic(kk_integer_t x, kk_integer_t y, kk_integ kk_integer_drop(y, ctx); return kk_integer_zero; } - else if (kk_integer_is_pos_borrow(x)) { + else if (kk_integer_is_pos_borrow(x,ctx)) { // positive x return kk_integer_cdiv_cmod_generic(x, y, mod, ctx); } else { // regular kk_integer_t m; - kk_integer_t d = kk_integer_cdiv_cmod_generic(x, kk_integer_dup(y), &m, ctx); - if (kk_integer_is_neg_borrow(m)) { - if (kk_integer_is_neg_borrow(y)) { + kk_integer_t d = kk_integer_cdiv_cmod_generic(x, kk_integer_dup(y, ctx), &m, ctx); + if (kk_integer_is_neg_borrow(m,ctx)) { + if (kk_integer_is_neg_borrow(y, ctx)) { d = kk_integer_inc(d, ctx); if (mod!=NULL) { - m = kk_integer_sub(m, kk_integer_dup(y), ctx); + m = kk_integer_sub(m, kk_integer_dup(y, ctx), ctx); } } else { d = kk_integer_dec(d, ctx); if (mod!=NULL) { - m = kk_integer_add(m, kk_integer_dup(y), ctx); + m = kk_integer_add(m, kk_integer_dup(y, ctx), ctx); } } } @@ -1538,7 +1540,7 @@ kk_decl_export kk_string_t kk_integer_to_hex_string(kk_integer_t x, bool use_cap void kk_integer_fprint(FILE* f, kk_integer_t x, kk_context_t* ctx) { kk_string_t s = kk_integer_to_string(x, ctx); - fprintf(f, "%s", kk_string_cbuf_borrow(s,NULL)); + fprintf(f, "%s", kk_string_cbuf_borrow(s,NULL,ctx)); kk_string_drop(s, ctx); } @@ -1552,8 +1554,8 @@ void kk_integer_print(kk_integer_t x, kk_context_t* ctx) { ----------------------------------------------------------------------*/ // count trailing decimal zeros -static kk_intx_t int_ctz(kk_intx_t x) { - kk_intx_t count = 0; +static int int_ctz(kk_intx_t x) { + int count = 0; for (; x != 0 && (x%10) == 0; x /= 10) { count++; } @@ -1580,11 +1582,11 @@ kk_integer_t kk_integer_ctz(kk_integer_t x, kk_context_t* ctx) { } } -static kk_intx_t int_count_digits(kk_intx_t x) { +static kk_intf_t int_count_digits(kk_intf_t x) { // make positive kk_uintx_t u; if (x < 0) { - u = (kk_uintx_t)(x == KK_INTX_MIN ? KK_INTX_MAX : -x); // careful for overflow + u = (kk_uintx_t)(x == KK_INTF_MIN ? KK_INTF_MAX : -x); // careful for overflow } else { u = (kk_uintx_t)x; @@ -1633,7 +1635,7 @@ kk_integer_t kk_integer_mul_pow10(kk_integer_t x, kk_integer_t p, kk_context_t* // TODO: raise error return kk_integer_zero; } - kk_intx_t i = kk_smallint_from_integer(p); + kk_intf_t i = kk_smallint_from_integer(p); // negative? if (i < 0) { @@ -1679,7 +1681,7 @@ kk_integer_t kk_integer_cdiv_pow10(kk_integer_t x, kk_integer_t p, kk_context_t* // TODO: raise error return kk_integer_zero; } - kk_intx_t i = kk_smallint_from_integer(p); + kk_intf_t i = kk_smallint_from_integer(p); // negative? if (i < 0) { @@ -1720,7 +1722,7 @@ kk_integer_t kk_integer_cdiv_pow10(kk_integer_t x, kk_integer_t p, kk_context_t* } kk_integer_t kk_integer_div_pow10(kk_integer_t x, kk_integer_t p, kk_context_t* ctx) { - bool xneg = kk_integer_is_neg_borrow(x); + bool xneg = kk_integer_is_neg_borrow(x, ctx); kk_integer_t d = kk_integer_cdiv_pow10(x, p, ctx); if (xneg) { d = kk_integer_dec(d, ctx); @@ -1735,20 +1737,20 @@ kk_integer_t kk_integer_div_pow10(kk_integer_t x, kk_integer_t p, kk_context_t* static bool kk_digit_to_uint64_ovf(kk_digit_t d, uint64_t* u) { #if (BASE > UINT64_MAX) - if (kk_unlikely(d > UINT64_MAX)) return true; + if kk_unlikely(d > UINT64_MAX) return true; #endif *u = d; return false; } static bool kk_uint64_add_ovf(uint64_t x, uint64_t y, uint64_t* z) { - if (kk_unlikely(x > (UINT64_MAX - y))) return true; + if kk_unlikely(x > (UINT64_MAX - y)) return true; *z = x + y; return false; } static bool kk_uint64_mul_ovf(uint64_t x, uint64_t y, uint64_t* z) { - if (kk_unlikely(x > (UINT64_MAX / y))) return true; + if kk_unlikely(x > (UINT64_MAX / y)) return true; *z = x*y; return false; } diff --git a/kklib/src/os.c b/kklib/src/os.c index aa7f60a7c..c141f1756 100644 --- a/kklib/src/os.c +++ b/kklib/src/os.c @@ -227,7 +227,7 @@ kk_decl_export int kk_os_write_text_file(kk_string_t path, kk_string_t content, } err = 0; kk_ssize_t len; - const uint8_t* buf = kk_string_buf_borrow(content, &len); + const uint8_t* buf = kk_string_buf_borrow(content, &len, ctx); if (len > 0) { kk_ssize_t nwritten; err = kk_posix_write_retry(f, buf, len, &nwritten); @@ -280,7 +280,7 @@ static bool kk_is_dir(const char* cpath) { } #endif -kk_decl_export int kk_os_ensure_dir(kk_string_t path, int mode, kk_context_t* ctx) +int kk_os_ensure_dir(kk_string_t path, int mode, kk_context_t* ctx) { int err = 0; if (mode < 0) { @@ -552,18 +552,18 @@ kk_decl_export int kk_os_list_directory(kk_string_t dir, kk_vector_t* contents, kk_ssize_t count = 0; kk_ssize_t len = 100; - kk_vector_t vec = kk_vector_alloc(len, kk_integer_box(kk_integer_zero), ctx); + kk_vector_t vec = kk_vector_alloc(len, kk_integer_box(kk_integer_zero,ctx), ctx); do { kk_string_t name = os_direntry_name(&entry, ctx); - if (!kk_string_is_empty_borrow(name)) { + if (!kk_string_is_empty_borrow(name,ctx)) { // push name if (count >= len) { // realloc vector const kk_ssize_t newlen = (len > 1000 ? len + 1000 : 2*len); - vec = kk_vector_realloc(vec, newlen, kk_integer_box(kk_integer_zero), ctx); + vec = kk_vector_realloc(vec, newlen, kk_integer_box(kk_integer_zero,ctx), ctx); len = newlen; } - (kk_vector_buf_borrow(vec, NULL))[count] = kk_string_box(name); + (kk_vector_buf_borrow(vec, NULL,ctx))[count] = kk_string_box(name); count++; } else { @@ -573,7 +573,7 @@ kk_decl_export int kk_os_list_directory(kk_string_t dir, kk_vector_t* contents, os_findclose(d); if(count != len) { - *contents = kk_vector_realloc(vec, count, kk_box_null, ctx); + *contents = kk_vector_realloc(vec, count, kk_box_null(), ctx); } return err; } @@ -791,7 +791,7 @@ kk_string_t kk_os_realpath(kk_string_t path, kk_context_t* ctx) { DWORD res = GetFullPathNameW(wpath, 264, buf, NULL); if (res == 0) { // failure - rpath = kk_string_dup(path); + rpath = kk_string_dup(path,ctx); } else if (res >= 264) { DWORD pbuflen = res; @@ -799,7 +799,7 @@ kk_string_t kk_os_realpath(kk_string_t path, kk_context_t* ctx) { res = GetFullPathNameW(wpath, pbuflen, pbuf, NULL); if (res == 0 || res >= pbuflen) { // failed again - rpath = kk_string_dup(path); + rpath = kk_string_dup(path,ctx); } else { rpath = kk_string_alloc_from_qutf16w(pbuf, ctx); @@ -869,7 +869,7 @@ static kk_string_t kk_os_searchpathx(const char* paths, const char* fname, kk_co buf[plen+1+fnamelen] = 0; p = (r == pend ? r : r + 1); kk_string_t sfname = kk_string_alloc_from_qutf8(buf, ctx); - if (kk_os_is_file( kk_string_dup(sfname), ctx)) { + if (kk_os_is_file( kk_string_dup(sfname,ctx), ctx)) { s = kk_os_realpath(sfname,ctx); break; } @@ -910,7 +910,7 @@ static kk_string_t kk_os_app_path_generic(kk_context_t* ctx) { else { // basename, try to prefix with all entries in PATH kk_string_t s = kk_os_searchpathx(getenv("PATH"), p, ctx); - if (kk_string_is_empty_borrow(s)) s = kk_os_realpath(kk_string_alloc_from_qutf8(p,ctx),ctx); + if (kk_string_is_empty_borrow(s, ctx)) { s = kk_os_realpath(kk_string_alloc_from_qutf8(p, ctx), ctx); } return s; } } @@ -979,7 +979,7 @@ kk_string_t kk_os_app_path(kk_context_t* ctx) { kk_string_t kk_os_app_path(kk_context_t* ctx) { kk_string_t s = kk_os_realpath(kk_string_alloc_dup_valid_utf8(KK_PROC_SELF,ctx),ctx); - if (strcmp(kk_string_cbuf_borrow(s,NULL), KK_PROC_SELF)==0) { + if (strcmp(kk_string_cbuf_borrow(s,NULL,ctx), KK_PROC_SELF)==0) { // failed? try generic search kk_string_drop(s, ctx); return kk_os_app_path_generic(ctx); @@ -1245,4 +1245,16 @@ bool kk_cpu_is_little_endian(kk_context_t* ctx) { #else return false; #endif -} \ No newline at end of file +} + +int kk_cpu_address_bits(kk_context_t* ctx) { + kk_unused(ctx); + size_t bsize; + #if __CHERI__ + bsize = sizeof(vaddr_t); + #else + bsize = sizeof(void*); + #endif + return (int)(CHAR_BIT * bsize); +} + diff --git a/kklib/src/process.c b/kklib/src/process.c index 01c1285fd..4f47d2990 100644 --- a/kklib/src/process.c +++ b/kklib/src/process.c @@ -7,70 +7,6 @@ ---------------------------------------------------------------------------*/ #include "kklib.h" -#define KK_USEC_PER_SEC 1000000 - -// ---------------------------------------------------------------- -// Basic timer for convenience; use micro-seconds to avoid doubles -// (2^63-1) us ~= 292471 years -// ---------------------------------------------------------------- -#ifdef WIN32 -#include -static kk_usecs_t kk_to_usecs(LARGE_INTEGER t) { - static LARGE_INTEGER mfreq; // = 0 - if (mfreq.QuadPart == 0) { - QueryPerformanceFrequency(&mfreq); - //mfreq.QuadPart = f.QuadPart/I64(1000000); - if (mfreq.QuadPart == 0) mfreq.QuadPart = 1000; - } - // calculate in parts to avoid overflow - int64_t secs = t.QuadPart / mfreq.QuadPart; - int64_t frac = t.QuadPart % mfreq.QuadPart; - kk_usecs_t u = secs*KK_USEC_PER_SEC + ((frac*KK_USEC_PER_SEC)/mfreq.QuadPart); - return u; -} - -static kk_usecs_t kk_timer_now(void) { - LARGE_INTEGER t; - QueryPerformanceCounter(&t); - return kk_to_usecs(t); -} -#else -#include -#ifdef CLOCK_REALTIME -static kk_usecs_t kk_timer_now(void) { - struct timespec t; - clock_gettime(CLOCK_REALTIME, &t); - return ((kk_usecs_t)t.tv_sec * KK_USEC_PER_SEC) + ((kk_usecs_t)t.tv_nsec/1000); -} -#else -// low resolution timer -static kk_usecs_t kk_timer_now(void) { - int64_t t = (int64_t)clock(); - // calculate in parts to avoid overflow - int64_t secs = t / (int64_t)CLOCKS_PER_SEC; - int64_t frac = t % (int64_t)CLOCKS_PER_SEC; - return (secs*KK_USEC_PER_SEC + ((frac*KK_USEC_PER_SEC)/CLOCKS_PER_SEC); -} -#endif -#endif - -static kk_usecs_t kk_timer_diff; - -kk_timer_t kk_timer_start(void) { - if (kk_timer_diff == 0) { - kk_timer_t t0 = kk_timer_now(); - kk_timer_diff = kk_timer_now() - t0; - if (kk_timer_diff==0) kk_timer_diff = 1; - } - return kk_timer_now(); -} - -kk_usecs_t kk_timer_end(kk_timer_t start) { - kk_usecs_t end = kk_timer_now(); - return (end - start - kk_timer_diff); -} - - // -------------------------------------------------------- // Basic process statistics // -------------------------------------------------------- diff --git a/kklib/src/random.c b/kklib/src/random.c index a1f887eff..c4b77450b 100644 --- a/kklib/src/random.c +++ b/kklib/src/random.c @@ -226,7 +226,7 @@ uint32_t kk_srandom_range_uint32(uint32_t max, kk_context_t* ctx) { uint32_t x = kk_srandom_uint32(ctx); uint64_t m = (uint64_t)x * (uint64_t)max; uint32_t l = (uint32_t)m; - if (kk_unlikely(l < max)) { + if kk_unlikely(l < max) { uint32_t threshold = (~max+1) % max; /* 2^32 % max == (2^32 - max) % max == -max % max */ while (l < threshold) { x = kk_srandom_uint32(ctx); diff --git a/kklib/src/ref.c b/kklib/src/ref.c index 5b7bac6c7..e8e9a8c5c 100644 --- a/kklib/src/ref.c +++ b/kklib/src/ref.c @@ -9,7 +9,7 @@ // Atomic path for mutable references -kk_decl_export kk_box_t kk_ref_get_thread_shared(kk_ref_t r, kk_context_t* ctx) { +kk_decl_export kk_box_t kk_ref_get_thread_shared(struct kk_ref_s* r, kk_context_t* ctx) { // careful: we cannot first read and then dup the read value as it may be // overwritten and _dropped_ by another thread in between. To avoid this // situation we first atomically swap with a guard value 0, then dup, and @@ -22,20 +22,20 @@ again: ; if (b.box == 0) { b.box = 1; } // expect any value but 0 } while (!kk_atomic_cas_weak_relaxed(&r->value, &b.box, 0)); // we got it, and hold the "locked" reference (`r->value == 0`) - kk_box_dup(b); + kk_box_dup(b,ctx); // and release our lock by writing back `b` - uintptr_t guard = 0; - while (!kk_atomic_cas_strong_relaxed(&r->value, &guard, b.box)) { + kk_intb_t guard = 0; + while (!kk_atomic_cas_strong_relaxed(&r->value, &guard, b.box)) { assert(false); // should never happen! as a last resort, restart the operation kk_box_drop(b,ctx); goto again; } - kk_ref_drop(r, ctx); + kk_block_drop(&r->_block, ctx); return b; } -kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(kk_ref_t r, kk_box_t value) { +kk_decl_export kk_box_t kk_ref_swap_thread_shared_borrow(struct kk_ref_s* r, kk_box_t value) { // atomically swap, but not if guarded with 0 (to not interfere with a `ref_get`) kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); diff --git a/kklib/src/refcount.c b/kklib/src/refcount.c index 655a8ad99..8be9481c4 100644 --- a/kklib/src/refcount.c +++ b/kklib/src/refcount.c @@ -25,7 +25,7 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { const kk_ssize_t scan_fsize = b->header.scan_fsize; if (scan_fsize==0) { // TODO: can we avoid raw object tests? - if (kk_unlikely(kk_tag_is_raw(kk_block_tag(b)))) { kk_block_free_raw(b,ctx); } + if kk_unlikely(kk_tag_is_raw(kk_block_tag(b))) { kk_block_free_raw(b,ctx); } kk_block_free(b,ctx); // deallocate directly if nothing to scan } else { @@ -41,14 +41,15 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { Checked reference counts. positive: - 0 : unique reference - 0x00000001 - 0x7FFFFFFF : reference count (in a single thread) (~2.1e9 counts) + 0 : unique reference + 1 to INT32_MAX : reference count (in a single thread) (~2.1e9 counts) + negative: - 0x80000000 : sticky: single-threaded stricky reference count (RC_STUCK) - 0x80000001 - 0x90000000 : sticky: neither increment, nor decrement - 0x90000001 - 0xA0000000 : sticky: still decrements (dup) but no more increments (drop) - 0xA0000001 - 0xFFFFFFFF : thread-shared reference counts with atomic increment/decrement. (~1.6e9 counts) - 0xFFFFFFFF : RC_SHARED_UNIQUE (-1) + INT32_MIN : sticky: single-threaded stricky reference count (RC_STUCK) + INT32_MIN+1 to INT32_MIN+0x10000000 : sticky: neither increment, nor decrement + INT32_MIN+0x10000001 to INT32_MIN+0x20000000 : sticky: still decrements (dup) but no more increments (drop) + INT32_MIN+0x20000001 to -2 : thread-shared reference counts with atomic increment/decrement. (~1.6e9 counts) + -1 : thread-shared reference count that is unique now (RC_SHARED_UNIQUE) 0 <= refcount <= MAX_INT32 @@ -59,11 +60,18 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { MAX_INT32 < refcount <= MAX_UINT32 Thread-shared and sticky reference counts. These use atomic increment/decrement operations. - MAX_INT32 + 1 == RC_STUCK + MIN_INT32 == RC_STUCK This is used for single threaded refcounts that overflow. (This is sticky and the object will never be freed) The thread-shared refcounts will never get there. - MAX_INT32 < refcount <= RC_STICKY_DROP + RC_STICKY_DROP < refcount <= -1 (= RC_UNIQUE_SHARED) + A thread-shared reference count. + The reference count grows down, e.g. if there are N references to a + thread-shared object, then the reference count is -N. + It means that to dup a thread-shared reference will _decrement_ the count, + and to drop will _increment_ the count. + + MIN_INT32 < refcount <= RC_STICKY_DROP The sticky range. An object in this range will never be freed anymore. Since we first read the reference count non-atomically we need a range for stickiness. Once `refcount <= RC_STICKY_DROP` it will never drop anymore @@ -71,13 +79,6 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { We assume that the relaxed reads of the reference counts catch up to the atomic value within the sticky range (which has a range of ~0.5e9 counts). - RC_STICKY_DROP < refcount <= MAX_UINT32 (= RC_UNIQUE_SHARED) - A thread-shared reference count. - The reference count grows down, e.g. if there are N references to a thread-shared object - the reference count is (RC_UNIQUE_SHARED - N + 1), (i.e. in a signed representation it is -N). - It means that to dup a thread-shared reference will _decrement_ the count, - and to drop will _increment_ the count. - Atomic memory ordering: - Increments can be relaxed as there is no dependency on order, the owner could access fields just as well before or after incrementing. @@ -89,10 +90,12 @@ static void kk_block_drop_free(kk_block_t* b, kk_context_t* ctx) { - see also: https://devblogs.microsoft.com/oldnewthing/20210409-00/?p=105065 --------------------------------------------------------------------------------------*/ -#define RC_STUCK KK_U32(0x80000000) -#define RC_STICKY KK_U32(0x90000000) -#define RC_STICKY_DROP KK_U32(0xA0000000) -#define RC_SHARED_UNIQUE KK_U32(0xFFFFFFFF) +#define RC_STUCK INT32_MIN +#define RC_STICKY (RC_STUCK + 0x10000000) +#define RC_STICKY_DROP (RC_STUCK + 0x20000000) +#define RC_SHARED_UNIQUE KK_I32(-1) +#define RC_UNIQUE KK_I32(0) + static inline kk_refcount_t kk_atomic_dup(kk_block_t* b) { return kk_atomic_dec_relaxed(&b->header.refcount); @@ -106,20 +109,22 @@ static inline kk_refcount_t kk_atomic_acquire(kk_block_t* b) { static void kk_block_make_shared(kk_block_t* b) { kk_refcount_t rc = kk_block_refcount(b); - kk_assert_internal(rc <= RC_STUCK); // not thread shared already - rc = RC_SHARED_UNIQUE - rc; // signed: -1 - rc - if (rc <= RC_STICKY_DROP) rc = RC_STICKY; // for high reference counts - kk_block_refcount_set(b, rc); + kk_assert_internal(!kk_refcount_is_thread_shared(rc)); // not thread shared already + if (!kk_refcount_is_thread_shared(rc)) { + rc = -rc; // cannot overflow as rc is positive + if (rc <= RC_STICKY_DROP) { rc = RC_STICKY; } // for high reference counts default to sticky + kk_block_refcount_set(b, rc); + } } // Check if a reference dup needs an atomic operation kk_decl_noinline kk_block_t* kk_block_check_dup(kk_block_t* b, kk_refcount_t rc0) { kk_assert_internal(b!=NULL); kk_assert_internal(kk_refcount_is_thread_shared(rc0)); // includes KK_STUCK - if (kk_likely(rc0 > RC_STICKY)) { - kk_atomic_dup(b); + if kk_likely(rc0 > RC_STICKY) { + kk_atomic_dup(b); // decrement } - // else sticky: no longer increment (or decrement) + // else sticky: no longer dup (= decrement) return b; } @@ -130,14 +135,14 @@ kk_decl_noinline void kk_block_check_drop(kk_block_t* b, kk_refcount_t rc0, kk_c kk_assert_internal(b!=NULL); kk_assert_internal(kk_block_refcount(b) == rc0); kk_assert_internal(rc0 == 0 || kk_refcount_is_thread_shared(rc0)); - if (kk_likely(rc0==0)) { + if kk_likely(rc0==0) { kk_block_drop_free(b, ctx); // no more references, free it. } - else if (kk_unlikely(rc0 <= RC_STICKY_DROP)) { + else if kk_unlikely(rc0 <= RC_STICKY_DROP) { // sticky: do not drop further } else { - const kk_refcount_t rc = kk_atomic_drop(b); + const kk_refcount_t rc = kk_atomic_drop(b); // increment if (rc == RC_SHARED_UNIQUE) { // this was the last reference? kk_atomic_acquire(b); // prevent reordering of reads/writes before this point kk_block_refcount_set(b,0); // no longer shared @@ -152,13 +157,13 @@ kk_decl_noinline kk_reuse_t kk_block_check_drop_reuse(kk_block_t* b, kk_refcount kk_assert_internal(b!=NULL); kk_assert_internal(kk_block_refcount(b) == rc0); kk_assert_internal(rc0 == 0 || kk_refcount_is_thread_shared(rc0)); - if (kk_likely(rc0==0)) { + if kk_likely(rc0==0) { // no more references, reuse it. kk_ssize_t scan_fsize = kk_block_scan_fsize(b); for (kk_ssize_t i = 0; i < scan_fsize; i++) { kk_box_drop(kk_block_field(b, i), ctx); } - kk_header_init(&b->header,0,KK_TAG_INVALID); // not really necessary + kk_header_init(&b->header,0,0,KK_TAG_INVALID); // not really necessary return b; } else { @@ -174,14 +179,14 @@ kk_decl_noinline void kk_block_check_decref(kk_block_t* b, kk_refcount_t rc0, kk kk_assert_internal(b!=NULL); kk_assert_internal(kk_block_refcount(b) == rc0); kk_assert_internal(rc0 == 0 || kk_refcount_is_thread_shared(rc0)); - if (kk_likely(rc0==0)) { + if kk_likely(rc0==0) { kk_free(b,ctx); // no more references, free it (without dropping children!) } - else if (kk_unlikely(rc0 <= RC_STICKY_DROP)) { + else if kk_unlikely(rc0 <= RC_STICKY_DROP) { // sticky: do not decrement further } else { - const kk_refcount_t rc = kk_atomic_drop(b); + const kk_refcount_t rc = kk_atomic_drop(b); // decrement if (rc == RC_SHARED_UNIQUE) { // last referenc? kk_block_refcount_set(b,0); // no longer shared kk_free(b,ctx); // no more references, free it. @@ -215,7 +220,7 @@ static bool kk_block_decref_no_free(kk_block_t* b) { if (rc==0) { return true; } - else if (kk_unlikely(kk_refcount_is_thread_shared(rc))) { + else if kk_unlikely(kk_refcount_is_thread_shared(rc)) { return (rc <= RC_STICKY_DROP ? false : block_thread_shared_decref_no_free(b)); } else { @@ -233,34 +238,26 @@ static bool kk_block_decref_no_free(kk_block_t* b) { // (and it is faster than a recursive version so we only have a stackless free) //----------------------------------------------------------------------------------------- -static inline uint8_t kk_decl_pure kk_block_field_idx(const kk_block_t* b) { - return b->header._field_idx; -} +// Check if a field `i` in a block `b` should be freed, i.e. it is heap allocated with a refcount of 0. +// Optimizes by already freeing leaf blocks that are heap allocated but have no scan fields. -static inline void kk_block_field_idx_set(kk_block_t* b, uint8_t idx ) { - b->header._field_idx = idx; -} - -// Check if a field `i` in a block `b` should be freed, i.e. it is heap allocated with a refcount of 0. -// Optimizes by already freeing leaf blocks that are heap allocated but have no scan fields. -static inline kk_block_t* kk_block_field_should_free(kk_block_t* b, kk_ssize_t field, kk_context_t* ctx) -{ - kk_box_t v = kk_block_field(b, field); +static inline kk_block_t* kk_block_field_should_free(kk_block_t* b, kk_ssize_t field, kk_context_t* ctx) { + kk_box_t v = kk_block_field(b, field); if (kk_box_is_non_null_ptr(v)) { - kk_block_t* child = kk_ptr_unbox(v); + kk_block_t* child = kk_ptr_unbox(v,ctx); + kk_assert_internal(kk_block_is_valid(child)); if (kk_block_decref_no_free(child)) { - uint8_t v_scan_fsize = child->header.scan_fsize; - if (v_scan_fsize == 0) { - // free leaf nodes directly and pretend it was not a ptr field - if (kk_unlikely(kk_tag_is_raw(kk_block_tag(child)))) { kk_block_free_raw(child, ctx); } // potentially call custom `free` function on the data - kk_block_free(child,ctx); - } - else { - return child; + uint8_t v_scan_fsize = child->header.scan_fsize; + if (v_scan_fsize == 0) { // free leaf nodes directly and pretend it was not a ptr field + if kk_unlikely(kk_tag_is_raw(kk_block_tag(child))) { kk_block_free_raw(child,ctx); } // potentially call custom `free` function on the data + kk_block_free(child,ctx); + } + else { + return child; } } } - return NULL; + return NULL; } @@ -287,6 +284,91 @@ static kk_decl_noinline void kk_block_drop_free_large_rec(kk_block_t* b, kk_cont // Recursively free a block and drop its children without using stack space static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t* ctx) +{ + kk_assert_internal(b->header.scan_fsize > 0); + kk_block_t* parent = NULL; + uint8_t scan_fsize; + uint8_t i; // current field + + // ------- drop the children and free the block b ------------ + move_down: + kk_assert_internal(kk_block_is_valid(b)); + scan_fsize = b->header.scan_fsize; + kk_assert_internal(kk_block_refcount(b) == 0); + kk_assert_internal(scan_fsize > 0); // due to kk_block_should_free + if (scan_fsize == 1) { + // if just one field, we can free directly and continue with the child + kk_block_t* next = kk_block_field_should_free(b, 0, ctx); + kk_block_free(b,ctx); + if (next != NULL) { + b = next; + goto move_down; + } + // goto move_up; // fallthrough + } + else if (scan_fsize == 2 && !kk_box_is_non_null_ptr(kk_block_field(b,0))) { + // optimized code for lists/nodes with boxed first element + kk_block_t* next = kk_block_field_should_free(b, 1, ctx); + kk_block_free(b,ctx); + if (next != NULL) { + b = next; + goto move_down; + } + // goto move_up; // fallthrough + } + else if kk_unlikely(scan_fsize == KK_SCAN_FSIZE_MAX) { + kk_assert_internal(scan_fsize == KK_SCAN_FSIZE_MAX); + kk_block_drop_free_large_rec(b, ctx); + // goto move_up; // fallthrough + } + else { + // small block more than 1 field (but less then KK_SCAN_FSIZE_MAX) + i = 0; + + scan_fields: // i points to the starting field to scan + kk_assert_internal(i < scan_fsize); + // drop each field + do { + kk_block_t* child = kk_block_field_should_free(b, i, ctx); + i++; + if (child != NULL) { + // go down into the child + if (i < scan_fsize) { + // save our progress to continue here later (when moving up along the parent chain) + kk_block_field_set(b, 0, kk_box_from_potential_null_ptr(parent,ctx)); // set parent (use low-level box as parent could be NULL) + kk_block_field_idx_set(b,i); + parent = b; + } + else { + // the last field: free the block and continue with the child leaving the parent unchanged + kk_block_free(b,ctx); + } + // and continue with the child + b = child; + goto move_down; + } + } while (i < scan_fsize); + kk_block_free(b,ctx); + // goto move_up; // fallthrough + } + + // ------- move up along the parent chain ------------ + // move_up: + if (parent != NULL) { + b = parent; + parent = kk_box_to_potential_null_ptr( kk_block_field(parent, 0), ctx ); // low-level unbox as it can be NULL + scan_fsize = b->header.scan_fsize; + i = kk_block_field_idx(b); + kk_assert_internal(i < scan_fsize); + goto scan_fields; + } + + // done +} + +#if 0 +// Recursively free a block and drop its children without using stack space +static kk_decl_noinline void kk_block_drop_free_rec_old(kk_block_t* b, kk_context_t* ctx) { kk_assert_internal(b->header.scan_fsize > 0); kk_block_t* parent = NULL; @@ -350,7 +432,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t } // ------- move up along the parent chain ------------ - while (kk_likely(parent != NULL)) { + while kk_likely(parent != NULL) { // go up to parent uint8_t i = kk_block_field_idx(parent); scan_fsize = parent->header.scan_fsize; @@ -382,7 +464,7 @@ static kk_decl_noinline void kk_block_drop_free_recx(kk_block_t* b, kk_context_t } // done } - +#endif //----------------------------------------------------------------------------------------- // Mark a block and all children recursively as thread shared @@ -403,7 +485,7 @@ static inline kk_block_t* kk_block_field_should_mark(kk_block_t* b, kk_ssize_t f kk_unused(ctx); kk_box_t v = kk_block_field(b, field); if (kk_box_is_non_null_ptr(v)) { - kk_block_t* child = kk_ptr_unbox(v); + kk_block_t* child = kk_ptr_unbox(v,ctx); if (!kk_block_is_thread_shared(child)) { if (child->header.scan_fsize == 0) { // mark leaf objects directly as shared @@ -453,7 +535,7 @@ static kk_decl_noinline void kk_block_mark_shared_rec(kk_block_t* b, const kk_ss if (depth < MAX_RECURSE_DEPTH) { kk_block_make_shared(b); kk_ssize_t i = 0; - if (kk_unlikely(scan_fsize >= KK_SCAN_FSIZE_MAX)) { + if kk_unlikely(scan_fsize >= KK_SCAN_FSIZE_MAX) { scan_fsize = (kk_ssize_t)kk_intf_unbox(kk_block_field(b, 0)); i++; // skip scan field } @@ -496,61 +578,103 @@ static kk_decl_noinline void kk_block_mark_shared_recx_large(kk_block_t* b, kk_c kk_block_make_shared(b); } +// Unfortunately, we cannot use the _field_idx as the index for marking +// as we also use it for tail recursion context paths. Such TRMC structure may +// be captured under a lambda (by yielding for example) and that might become +// thread shared and we cannot overwrite such indices. +// (This is unlike freeing where we can use it as we are freeing it anyways) +// So, we steal 8 bits of an unshared reference count. If the reference count +// is too large we just set it to RC_STUCK when it gets marked. +#define KK_RC_MARK_MAX KK_I32(0x007FFFFF) + +static void kk_block_mark_idx_prepare(kk_block_t* b) { + kk_refcount_t rc = kk_block_refcount(b); + kk_assert_internal(!kk_refcount_is_thread_shared(rc)); + if (rc > KK_RC_MARK_MAX) { rc = KK_RC_MARK_MAX; } // if rc is too large, cap it + rc = kk_shl32(rc,8); // make room for 8-bit mark index + kk_assert_internal(rc>=0); + kk_assert_internal((rc & 0xFF) == 0); + kk_block_refcount_set(b, rc); +} + +static void kk_block_mark_idx_done(kk_block_t* b) { + kk_refcount_t rc = kk_block_refcount(b); + kk_assert_internal(!kk_refcount_is_thread_shared(rc)); + rc = kk_shr32(rc, 8); + if (rc >= KK_RC_MARK_MAX) { rc = INT32_MAX; } // ensure it will become stuck if it was too large to contain an index + kk_block_refcount_set(b, rc); +} + +static void kk_block_mark_idx_set(kk_block_t* b, uint8_t i) { + kk_refcount_t rc = kk_block_refcount(b); + kk_assert_internal(!kk_refcount_is_thread_shared(rc)); + rc = ((rc & ~0xFF) | i); + kk_block_refcount_set(b, rc); +} + +static uint8_t kk_block_mark_idx(kk_block_t* b) { + kk_refcount_t rc = kk_block_refcount(b); + kk_assert_internal(!kk_refcount_is_thread_shared(rc)); + return (uint8_t)rc; +} + // Stackless marking by using pointer reversal static kk_decl_noinline void kk_block_mark_shared_recx(kk_block_t* b, kk_context_t* ctx) { + fprintf(stderr, "mark shared recx\n"); kk_block_t* parent = NULL; if (kk_block_is_thread_shared(b)) return; if (b->header.scan_fsize == 0) return; - uint8_t i = 0; - uint8_t scan_fsize = b->header.scan_fsize; + uint8_t i; + uint8_t scan_fsize; - // ---- marking fields ----- -markfields: - kk_assert_internal(scan_fsize > 0); +recurse: + kk_assert_internal(!kk_block_is_thread_shared(b)); // due to kk_block_field_should_mark + scan_fsize = b->header.scan_fsize; if (scan_fsize == KK_SCAN_FSIZE_MAX) { - // recurse over the stack for large objects (vectors) + // stack recurse over the stack for large objects (vectors) kk_block_mark_shared_recx_large(b, ctx); } else { - do { + i = 0; + kk_block_mark_idx_prepare(b); + + // ---- marking fields starting at field `i` upto `scan_fsize` ----- +markfields: + kk_assert_internal(scan_fsize > 0); + kk_assert_internal(i <= scan_fsize); + while (i < scan_fsize) { kk_block_t* child = kk_block_field_should_mark(b, i, ctx); i++; if (child != NULL) { - // move down - // remember our state and link back to the parent - kk_block_field_set(b, i-1, _kk_box_new_ptr(parent)); // low-level box as parent can be NULL + // visit the child, but remember our state and link back to the parent + // note: we cannot optimize for the last child as in freeing as we need to restore all parent fields + kk_block_field_set(b, i - 1, kk_box_from_potential_null_ptr(parent,ctx)); // low-level box as parent can be NULL + kk_block_mark_idx_set(b, i); parent = b; - kk_block_field_idx_set(parent,i); b = child; - i = 0; - scan_fsize = b->header.scan_fsize; - goto markfields; + goto recurse; } - } while (i < scan_fsize); + } + kk_block_mark_idx_done(b); kk_block_make_shared(b); } - //--- moving back up ------------------ - while (parent != NULL) { + //--- moving back up along the parent chain ------------------ + if (parent != NULL) { // move up - i = kk_block_field_idx(parent); - kk_block_t* pparent = _kk_box_ptr( kk_block_field(parent, i-1) ); // low-level unbox on parent - kk_block_field_set(parent, i-1, kk_ptr_box(b)); // restore original pointer + i = kk_block_mark_idx(parent); + scan_fsize = parent->header.scan_fsize; + kk_assert_internal(i > 0 && i <= scan_fsize); + kk_block_t* pparent = kk_box_to_potential_null_ptr( kk_block_field(parent, i-1), ctx ); // low-level unbox on parent + kk_block_field_set(parent, i-1, kk_ptr_box(b,ctx)); // restore original pointer b = parent; parent = pparent; - // and continue visiting the fields - scan_fsize = b->header.scan_fsize; - if (i >= scan_fsize) { - kk_assert_internal(i == scan_fsize); - // done, keep moving up - kk_block_make_shared(b); - } - else { - // mark the rest of the fields starting at `i` upto `scan_fsize` - goto markfields; - } + kk_assert_internal(!kk_block_is_thread_shared(b)); + // mark the rest of the fields starting at `i` upto `scan_fsize` + goto markfields; } + // done } @@ -568,13 +692,56 @@ kk_decl_export void kk_block_mark_shared( kk_block_t* b, kk_context_t* ctx ) { kk_decl_export void kk_box_mark_shared( kk_box_t b, kk_context_t* ctx ) { if (kk_box_is_non_null_ptr(b)) { - kk_block_mark_shared( kk_ptr_unbox(b), ctx ); + kk_block_mark_shared( kk_ptr_unbox(b,ctx), ctx ); } } kk_decl_export void kk_box_mark_shared_recx(kk_box_t b, kk_context_t* ctx) { if (kk_box_is_non_null_ptr(b)) { - kk_block_mark_shared_recx(kk_ptr_unbox(b), ctx); + kk_block_mark_shared_recx(kk_ptr_unbox(b, ctx), ctx); } } + +/*-------------------------------------------------------------------------------------- + TRMC: copy a context following the context path indicated in the _field_idx. +--------------------------------------------------------------------------------------*/ + +#if defined(KK_HAS_MALLOC_COPY) +static kk_block_t* kk_block_alloc_copy( kk_block_t* b, kk_context_t* ctx ) { + kk_block_t* c = (kk_block_t*)kk_malloc_copy(b,ctx); + kk_block_refcount_set(c,0); + for( kk_ssize_t i = 0; i < kk_block_scan_fsize(b); i++) { + kk_box_dup(kk_block_field(c, i), ctx); + } + return c; +} +#endif + +#if !defined(KK_CCTX_NO_CONTEXT_PATH) +kk_decl_export kk_decl_noinline kk_box_t kk_cctx_copy_apply( kk_box_t res, kk_box_t* holeptr, kk_box_t child, kk_context_t* ctx) { + kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(res, ctx))); + kk_box_t cres = kk_box_null(); // copied result context + kk_box_t* next = NULL; // pointer to the context path field in the (copied) parent block + for( kk_box_t cur = res; true; cur = *next ) { + kk_assert_internal(kk_box_is_ptr(cur)); + kk_block_t* b = kk_ptr_unbox(cur, ctx); + const kk_ssize_t field = kk_block_field_idx(b) - 1; + kk_assert_internal(field >= 0); + kk_block_t* c = kk_block_alloc_copy(b,ctx); + if (next == NULL) { + cres = kk_ptr_box(c, ctx); + } + else { + kk_box_drop(*next,ctx); + *next = kk_ptr_box(c, ctx); + } + next = kk_block_field_address(c,field); + if (kk_block_field_address(b, field) == holeptr) break; + }; + kk_assert_internal(next != NULL); + *next = child; + kk_box_drop(res,ctx); + return cres; +} +#endif diff --git a/kklib/src/string.c b/kklib/src/string.c index 04dea80e0..c15e18a6a 100644 --- a/kklib/src/string.c +++ b/kklib/src/string.c @@ -48,11 +48,11 @@ static kk_ssize_t kk_wcslen(const uint16_t* wstr) { } -int kk_string_icmp_borrow(kk_string_t str1, kk_string_t str2) { +int kk_string_icmp_borrow(kk_string_t str1, kk_string_t str2, kk_context_t* ctx) { kk_ssize_t len1; - const uint8_t* s1 = kk_string_buf_borrow(str1, &len1); + const uint8_t* s1 = kk_string_buf_borrow(str1, &len1, ctx); kk_ssize_t len2; - const uint8_t* s2 = kk_string_buf_borrow(str2, &len2); + const uint8_t* s2 = kk_string_buf_borrow(str2, &len2, ctx); kk_ssize_t minlen = (len1 <= len2 ? len1 : len2); int ord = kk_memicmp(s1, s2, minlen); if (ord == 0) { @@ -63,7 +63,7 @@ int kk_string_icmp_borrow(kk_string_t str1, kk_string_t str2) { } int kk_string_icmp(kk_string_t str1, kk_string_t str2, kk_context_t* ctx) { - int ord = kk_string_icmp_borrow(str1, str2); + int ord = kk_string_icmp_borrow(str1, str2, ctx); kk_string_drop(str1, ctx); kk_string_drop(str2, ctx); return ord; @@ -71,9 +71,9 @@ int kk_string_icmp(kk_string_t str1, kk_string_t str2, kk_context_t* ctx) { // Count code points in a valid utf-8 string. -kk_ssize_t kk_decl_pure kk_string_count_borrow(kk_string_t str) { +kk_ssize_t kk_decl_pure kk_string_count_borrow(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); kk_ssize_t cont = 0; // continuation character counts const uint8_t* t = s; // current position const uint8_t* end = t + len; @@ -110,7 +110,7 @@ kk_ssize_t kk_decl_pure kk_string_count_borrow(kk_string_t str) { } kk_ssize_t kk_decl_pure kk_string_count(kk_string_t str, kk_context_t* ctx) { - kk_ssize_t count = kk_string_count_borrow(str); + kk_ssize_t count = kk_string_count_borrow(str,ctx); kk_string_drop(str, ctx); return count; } @@ -121,7 +121,7 @@ kk_ssize_t kk_decl_pure kk_string_count(kk_string_t str, kk_context_t* ctx) { --------------------------------------------------------------------------------------------------*/ kk_ssize_t kk_utf8_lenx(kk_char_t c) { - if (kk_likely(c <= 0x7F)) { + if kk_likely(c <= 0x7F) { return 1; } else if (c <= 0x07FF) { @@ -144,7 +144,7 @@ kk_ssize_t kk_utf8_lenx(kk_char_t c) { } void kk_utf8_writex(kk_char_t c, uint8_t* s, kk_ssize_t* count) { - if (kk_likely(c <= 0x7F)) { + if kk_likely(c <= 0x7F) { *count = 1; s[0] = (uint8_t)c; return; @@ -181,7 +181,7 @@ void kk_utf8_writex(kk_char_t c, uint8_t* s, kk_ssize_t* count) { kk_char_t kk_utf8_readx(const uint8_t* s, kk_ssize_t* count) { kk_char_t b = *s; kk_assert_internal(b >= 0); // shift left is not UB on b kk_char_t c; - if (kk_likely(b <= 0x7F)) { + if kk_likely(b <= 0x7F) { *count = 1; c = b; // fast path ASCII } @@ -210,8 +210,8 @@ kk_char_t kk_utf8_readx(const uint8_t* s, kk_ssize_t* count) { c = KK_RAW_UTF8_OFS + b; } #if (DEBUG!=0) - kk_ssize_t dcount = 0; - kk_ssize_t vcount = 0; + kk_ssize_t dcount; + kk_ssize_t vcount; kk_assert_internal(c == kk_utf8_read_validate(s, &dcount, &vcount, false)); kk_assert_internal(*count == dcount); #endif @@ -237,7 +237,7 @@ static inline bool kk_char_is_raw(kk_char_t c) { // invalid so they can be decoded back into the raw sequence) kk_char_t kk_utf8_read_validate(const uint8_t* s, kk_ssize_t* count, kk_ssize_t* vcount, bool qutf8_identity) { uint8_t b = s[0]; - if (kk_likely(b <= 0x7F)) { + if kk_likely(b <= 0x7F) { *count = 1; return b; // ASCII fast path } @@ -286,7 +286,7 @@ static bool kk_qutf8_validate(kk_ssize_t len, const uint8_t* s, bool qutf8_ident while (p < end) { // optimize for ascii // todo: optimize further with word reads? - if (kk_likely(*p < 0x80)) { + if kk_likely(*p < 0x80) { p++; vlen++; } @@ -330,7 +330,7 @@ static kk_string_t kk_qutf8_convert_from_invalid(kk_ssize_t len, const uint8_t* const uint8_t* p = s; const uint8_t* end = s + len; while (p < end) { - if (kk_likely(*p < 0x80)) { + if kk_likely(*p < 0x80) { *t++ = *p++; } else { @@ -344,7 +344,7 @@ static kk_string_t kk_qutf8_convert_from_invalid(kk_ssize_t len, const uint8_t* t += tcount; } } - kk_assert_internal((t - kk_string_buf_borrow(tstr, NULL)) == vlen); + kk_assert_internal((t - kk_string_buf_borrow(tstr, NULL, ctx)) == vlen); return tstr; } @@ -384,7 +384,7 @@ kk_string_t kk_string_convert_from_qutf8(kk_bytes_t str, kk_context_t* ctx) { // to avoid reallocation (to accommodate invalid sequences), we first check if // it is already valid utf-8 which should be very common; in that case we return the bytes/string as-is. kk_ssize_t len; - const uint8_t* const s = kk_bytes_buf_borrow(str, &len); + const uint8_t* const s = kk_bytes_buf_borrow(str, &len, ctx); kk_ssize_t vlen; bool valid = kk_qutf8_validate(len, s, true, &vlen); if (valid) { @@ -403,14 +403,14 @@ kk_string_t kk_string_convert_from_qutf8(kk_bytes_t str, kk_context_t* ctx) { const char* kk_string_to_qutf8_borrow(kk_string_t str, bool* should_free, kk_context_t* ctx) { // to avoid allocation, we first check if none of the characters are in the raw range. kk_ssize_t len; - const uint8_t* const s = kk_string_buf_borrow(str, &len); + const uint8_t* const s = kk_string_buf_borrow(str, &len, ctx); const uint8_t* const end = s + len; kk_ssize_t extra_count = 0; const uint8_t* p = s; while (p < end) { // optimize for ascii // todo: optimize further with word reads? - if (kk_likely(*p < 0x80)) { + if kk_likely(*p < 0x80) { p++; } else { @@ -438,7 +438,7 @@ const char* kk_string_to_qutf8_borrow(kk_string_t str, bool* should_free, kk_con while (p < end) { // optimize for ascii // todo: optimize further with word reads? - if (kk_likely(*p < 0x80)) { + if kk_likely(*p < 0x80) { *q++ = *p++; } else { @@ -467,7 +467,7 @@ const char* kk_string_to_qutf8_borrow(kk_string_t str, bool* should_free, kk_con uint16_t* kk_string_to_qutf16_borrow(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* const s = kk_string_buf_borrow(str, &len); + const uint8_t* const s = kk_string_buf_borrow(str, &len, ctx); const uint8_t* const end = s + len; // count utf-16 length (in 16-bit units) @@ -652,7 +652,7 @@ kk_string_t kk_string_alloc_from_codepage(const uint8_t* bstr, const uint16_t* c kk_utf8_write(c, s, &count); s += count; } - kk_assert_internal(s == (kk_string_buf_borrow(str, NULL) + len) && *s == 0); + kk_assert_internal(s == (kk_string_buf_borrow(str, NULL, ctx) + len) && *s == 0); return str; } @@ -661,12 +661,12 @@ kk_string_t kk_string_alloc_from_codepage(const uint8_t* bstr, const uint16_t* c String utilities --------------------------------------------------------------------------------------------------*/ -kk_ssize_t kk_decl_pure kk_string_count_pattern_borrow(kk_string_t str, kk_string_t pattern) { +kk_ssize_t kk_decl_pure kk_string_count_pattern_borrow(kk_string_t str, kk_string_t pattern, kk_context_t* ctx) { kk_ssize_t patlen; - const uint8_t* pat = kk_string_buf_borrow(pattern, &patlen); + const uint8_t* pat = kk_string_buf_borrow(pattern, &patlen, ctx); kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); - if (patlen <= 0) return kk_string_count_borrow(str); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); + if (patlen <= 0) return kk_string_count_borrow(str,ctx); if (patlen > len) return 0; //todo: optimize by doing backward Boyer-Moore? or use forward Knuth-Morris-Pratt? @@ -692,35 +692,35 @@ kk_string_t kk_string_from_char(kk_char_t c, kk_context_t* ctx) { kk_string_t kk_string_from_chars(kk_vector_t v, kk_context_t* ctx) { kk_ssize_t n; - kk_box_t* cs = kk_vector_buf_borrow(v, &n); + kk_box_t* cs = kk_vector_buf_borrow(v, &n, ctx); kk_ssize_t len = 0; for (kk_ssize_t i = 0; i < n; i++) { - len += kk_utf8_len(kk_char_unbox(cs[i], ctx)); + len += kk_utf8_len(kk_char_unbox(cs[i], KK_BORROWED, ctx)); } uint8_t* p; kk_string_t s = kk_unsafe_string_alloc_buf(len + 1, &p, ctx); for (kk_ssize_t i = 0; i < n; i++) { kk_ssize_t count; - kk_utf8_write(kk_char_unbox(cs[i], ctx), p, &count); + kk_utf8_write(kk_char_unbox(cs[i], KK_BORROWED, ctx), p, &count); p += count; } - kk_assert_internal(kk_string_buf_borrow(s, NULL) + n == p); + kk_assert_internal(kk_string_buf_borrow(s, NULL, ctx) + n == p); kk_vector_drop(v, ctx); return s; } kk_vector_t kk_string_to_chars(kk_string_t s, kk_context_t* ctx) { - kk_ssize_t n = kk_string_count_borrow(s); + kk_ssize_t n = kk_string_count_borrow(s,ctx); kk_box_t* cs; kk_vector_t v = kk_vector_alloc_uninit(n, &cs, ctx); kk_ssize_t len; - const uint8_t* p = kk_string_buf_borrow(s, &len); + const uint8_t* p = kk_string_buf_borrow(s, &len, ctx); for (kk_ssize_t i = 0; i < n; i++) { kk_ssize_t count; cs[i] = kk_char_box(kk_utf8_read(p, &count), ctx); p += count; } - kk_assert_internal(p == kk_string_buf_borrow(s, NULL) + len); + kk_assert_internal(p == kk_string_buf_borrow(s, NULL, ctx) + len); kk_string_drop(s, ctx); return v; } @@ -733,10 +733,10 @@ kk_vector_t kk_string_splitv_atmost(kk_string_t str, kk_string_t sepstr, kk_ssiz { if (n < 1) n = 1; kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); const uint8_t* const end = s + len; kk_ssize_t seplen; - const uint8_t* sep = kk_string_buf_borrow(sepstr, &seplen); + const uint8_t* sep = kk_string_buf_borrow(sepstr, &seplen, ctx); // count parts kk_ssize_t count = 1; @@ -748,7 +748,7 @@ kk_vector_t kk_string_splitv_atmost(kk_string_t str, kk_string_t sepstr, kk_ssiz } } else if (n > 1) { - count = kk_string_count_borrow(str); // todo: or special count upto n? + count = kk_string_count_borrow(str,ctx); // todo: or special count upto n? if (count > n) count = n; } kk_assert_internal(count >= 1 && count <= n); @@ -785,17 +785,17 @@ kk_vector_t kk_string_splitv_atmost(kk_string_t str, kk_string_t sepstr, kk_ssiz kk_string_t kk_string_to_upper(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); kk_string_t tstr; - if (kk_datatype_is_unique(str.bytes)) { + if (kk_datatype_is_unique(str.bytes, ctx)) { tstr = str; // update in-place } else { - kk_string_dup(str); // multi-thread safe as we still reference str with s + kk_string_dup(str, ctx); // multi-thread safe as we still reference str with s tstr = kk_string_copy(str, ctx); kk_assert_internal(!kk_datatype_eq(str.bytes, tstr.bytes)); } - uint8_t* t = (uint8_t*)kk_string_buf_borrow(tstr, NULL); // t & s may alias! + uint8_t* t = (uint8_t*)kk_string_buf_borrow(tstr, NULL, ctx); // t & s may alias! for (kk_ssize_t i = 0; i < len; i++) { t[i] = kk_ascii_toupper(s[i]); } @@ -805,17 +805,17 @@ kk_string_t kk_string_to_upper(kk_string_t str, kk_context_t* ctx) { kk_string_t kk_string_to_lower(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); kk_string_t tstr; - if (kk_datatype_is_unique(str.bytes)) { + if (kk_datatype_is_unique(str.bytes, ctx)) { tstr = str; // update in-place } else { - kk_string_dup(str); // multi-thread safe as we still reference str with s + kk_string_dup(str, ctx); // multi-thread safe as we still reference str with s tstr = kk_string_copy(str, ctx); kk_assert_internal(!kk_datatype_eq(str.bytes, tstr.bytes)); } - uint8_t* t = (uint8_t*)kk_string_buf_borrow(tstr, NULL); // t & s may alias! + uint8_t* t = (uint8_t*)kk_string_buf_borrow(tstr, NULL, ctx); // t & s may alias! for (kk_ssize_t i = 0; i < len; i++) { t[i] = kk_ascii_tolower(s[i]); } @@ -825,7 +825,7 @@ kk_string_t kk_string_to_lower(kk_string_t str, kk_context_t* ctx) { kk_string_t kk_string_trim_left(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); const uint8_t* p = s; for (; *p != 0 && kk_ascii_iswhite(*p); p++) {} if (p == s) return str; // no trim needed @@ -837,7 +837,7 @@ kk_string_t kk_string_trim_left(kk_string_t str, kk_context_t* ctx) { kk_string_t kk_string_trim_right(kk_string_t str, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* s = kk_string_buf_borrow(str, &len); + const uint8_t* s = kk_string_buf_borrow(str, &len, ctx); const uint8_t* p = s + len - 1; for (; p >= s && kk_ascii_iswhite(*p); p--) {} const kk_ssize_t tlen = (p - s) + 1; @@ -853,27 +853,27 @@ kk_string_t kk_string_trim_right(kk_string_t str, kk_context_t* ctx) { kk_unit_t kk_println(kk_string_t s, kk_context_t* ctx) { // TODO: set locale to utf-8? - puts(kk_string_cbuf_borrow(s, NULL)); // todo: allow printing embedded 0 characters? + puts(kk_string_cbuf_borrow(s, NULL, ctx)); // todo: allow printing embedded 0 characters? kk_string_drop(s, ctx); return kk_Unit; } kk_unit_t kk_print(kk_string_t s, kk_context_t* ctx) { // TODO: set locale to utf-8? - fputs(kk_string_cbuf_borrow(s, NULL), stdout); // todo: allow printing embedded 0 characters? + fputs(kk_string_cbuf_borrow(s, NULL, ctx), stdout); // todo: allow printing embedded 0 characters? kk_string_drop(s, ctx); return kk_Unit; } kk_unit_t kk_trace(kk_string_t s, kk_context_t* ctx) { - fputs(kk_string_cbuf_borrow(s, NULL), stderr); // todo: allow printing embedded 0 characters? + fputs(kk_string_cbuf_borrow(s, NULL, ctx), stderr); // todo: allow printing embedded 0 characters? fputs("\n", stderr); kk_string_drop(s, ctx); return kk_Unit; } kk_unit_t kk_trace_any(kk_string_t s, kk_box_t x, kk_context_t* ctx) { - fprintf(stderr, "%s: ", kk_string_cbuf_borrow(s, NULL)); + fprintf(stderr, "%s: ", kk_string_cbuf_borrow(s, NULL, ctx)); kk_string_drop(s, ctx); kk_trace(kk_show_any(x, ctx), ctx); return kk_Unit; @@ -940,26 +940,26 @@ kk_string_t kk_show_any(kk_box_t b, kk_context_t* ctx) { snprintf(buf, 128, "value(%li)", (long)kk_intf_unbox(b)); return kk_string_alloc_dup_valid_utf8(buf, ctx); } - else if (b.box == kk_box_null.box) { + else if (b.box == kk_box_null().box) { return kk_string_alloc_dup_valid_utf8("null", ctx); } else if (b.box == 0) { return kk_string_alloc_dup_valid_utf8("ptr(NULL)", ctx); } else { - kk_block_t* p = kk_ptr_unbox(b); + kk_block_t* p = kk_ptr_unbox(b, ctx); kk_tag_t tag = kk_block_tag(p); if (tag == KK_TAG_BIGINT) { // todo: add tag - return kk_integer_to_string(kk_integer_unbox(b), ctx); + return kk_integer_to_string(kk_integer_unbox(b, ctx), ctx); } else if (tag == KK_TAG_STRING_SMALL || tag == KK_TAG_STRING || tag == KK_TAG_STRING_RAW) { // todo: add tag return kk_string_unbox(b); } else if (tag == KK_TAG_FUNCTION) { - kk_function_t fun = kk_block_assert(kk_function_t, p, KK_TAG_FUNCTION); - snprintf(buf, 128, "function(0x%zx)", (uintptr_t)(kk_cptr_unbox(fun->fun))); + struct kk_function_s* fun = kk_block_assert(struct kk_function_s*, p, KK_TAG_FUNCTION); + snprintf(buf, 128, "function(0x%zx)", (uintptr_t)(kk_cptr_unbox_borrowed(fun->fun,ctx))); kk_box_drop(b, ctx); return kk_string_alloc_dup_valid_utf8(buf, ctx); } diff --git a/kklib/src/thread.c b/kklib/src/thread.c index 04ebf930b..08807e8c5 100644 --- a/kklib/src/thread.c +++ b/kklib/src/thread.c @@ -14,6 +14,7 @@ ---------------------------------------------------------------------------*/ #ifdef _WIN32 #include +#include // -------------------------------------- // Threads @@ -185,10 +186,10 @@ static kk_task_t* kk_task_alloc( kk_function_t fun, kk_promise_t p, kk_context_t } static void kk_task_exec( kk_task_t* task, kk_context_t* ctx ) { - if (task->fun != NULL) { - kk_function_dup(task->fun); - kk_box_t res = kk_function_call(kk_box_t,(kk_function_t,kk_context_t*),task->fun,(task->fun,ctx)); - kk_box_dup(task->promise); + if (!kk_function_is_null(task->fun,ctx)) { + kk_function_dup(task->fun,ctx); + kk_box_t res = kk_function_call(kk_box_t,(kk_function_t,kk_context_t*),task->fun,(task->fun,ctx),ctx); + kk_box_dup(task->promise,ctx); kk_promise_set( task->promise, res, ctx ); } kk_task_free(task,ctx); @@ -244,7 +245,7 @@ static void kk_tasks_enqueue( kk_task_group_t* tg, kk_task_t* task, kk_context_t static kk_promise_t kk_task_group_schedule( kk_task_group_t* tg, kk_function_t fun, kk_context_t* ctx ) { kk_promise_t p = kk_promise_alloc(ctx); - kk_task_t* task = kk_task_alloc(fun, kk_box_dup(p), ctx); + kk_task_t* task = kk_task_alloc(fun, kk_box_dup(p,ctx), ctx); pthread_mutex_lock(&tg->tasks_lock); kk_tasks_enqueue(tg,task,ctx); pthread_mutex_unlock(&tg->tasks_lock); @@ -361,7 +362,7 @@ static void kk_task_group_init(void) { kk_promise_t kk_task_schedule( kk_function_t fun, kk_context_t* ctx ) { pthread_once( &task_group_once, &kk_task_group_init ); kk_assert(task_group != NULL); - kk_block_mark_shared( &fun->_block, ctx ); // mark everything reachable from the task as shared + kk_block_mark_shared( kk_datatype_as_ptr(fun,ctx), ctx); // mark everything reachable from the task as shared if (ctx->task_group == NULL) { ctx->task_group = task_group; // let main thread participate instead of blocking on a promise.get } @@ -400,7 +401,7 @@ static kk_promise_t kk_promise_alloc(kk_context_t* ctx) { static void kk_promise_set( kk_promise_t pr, kk_box_t r, kk_context_t* ctx ) { - promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr); + promise_t* p = (promise_t*)kk_cptr_raw_unbox_borrowed(pr, ctx); kk_box_mark_shared(r,ctx); pthread_mutex_lock(&p->lock); kk_box_drop(p->result,ctx); @@ -422,7 +423,7 @@ static bool kk_promise_available( kk_promise_t pr, kk_context_t* ctx ) { */ kk_box_t kk_promise_get( kk_promise_t pr, kk_context_t* ctx ) { - promise_t* p = (promise_t*)kk_cptr_raw_unbox(pr); + promise_t* p = (promise_t*)kk_cptr_raw_unbox_borrowed(pr,ctx); pthread_mutex_lock(&p->lock); while (kk_box_is_any(p->result)) { // if part of a task group, run other tasks while waiting @@ -470,7 +471,7 @@ kk_box_t kk_promise_get( kk_promise_t pr, kk_context_t* ctx ) { } } pthread_mutex_unlock(&p->lock); - const kk_box_t result = kk_box_dup( p->result ); + const kk_box_t result = kk_box_dup( p->result,ctx ); kk_box_drop(pr,ctx); return result; } @@ -521,9 +522,9 @@ kk_lvar_t kk_lvar_alloc(kk_box_t init, kk_context_t* ctx) { void kk_lvar_put( kk_lvar_t lvar, kk_box_t val, kk_function_t monotonic_combine, kk_context_t* ctx ) { - lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar); + lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox_borrowed(lvar,ctx); pthread_mutex_lock(&lv->lock); - lv->result = kk_function_call(kk_box_t,(kk_function_t,kk_box_t,kk_box_t,kk_context_t*),monotonic_combine,(monotonic_combine,val,lv->result,ctx)); + lv->result = kk_function_call(kk_box_t,(kk_function_t,kk_box_t,kk_box_t,kk_context_t*),monotonic_combine,(monotonic_combine,val,lv->result,ctx),ctx); kk_box_mark_shared(lv->result,ctx); // todo: can we mark outside the mutex? pthread_mutex_unlock(&lv->lock); pthread_cond_signal(&lv->available); @@ -532,16 +533,16 @@ void kk_lvar_put( kk_lvar_t lvar, kk_box_t val, kk_function_t monotonic_combine, kk_box_t kk_lvar_get( kk_lvar_t lvar, kk_box_t bot, kk_function_t is_gte, kk_context_t* ctx ) { - lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox(lvar); + lvar_t* lv = (lvar_t*)kk_cptr_raw_unbox_borrowed(lvar,ctx); kk_box_t result; pthread_mutex_lock(&lv->lock); while (true) { - kk_function_dup(is_gte); - kk_box_dup(lv->result); - kk_box_dup(bot); - int32_t done = kk_function_call(int32_t,(kk_function_t,kk_box_t,kk_box_t,kk_context_t*),is_gte,(is_gte,lv->result,bot,ctx)); + kk_function_dup(is_gte,ctx); + kk_box_dup(lv->result,ctx); + kk_box_dup(bot,ctx); + int32_t done = kk_function_call(int32_t,(kk_function_t,kk_box_t,kk_box_t,kk_context_t*),is_gte,(is_gte,lv->result,bot,ctx),ctx); if (done != 0) { - result = kk_box_dup(lv->result); + result = kk_box_dup(lv->result,ctx); break; } // if part of a task group, run other tasks while waiting diff --git a/kklib/src/time.c b/kklib/src/time.c index bbfda5eaa..08e2bf1d0 100644 --- a/kklib/src/time.c +++ b/kklib/src/time.c @@ -7,20 +7,81 @@ ---------------------------------------------------------------------------*/ #include "kklib.h" + +/*-------------------------------------------------------------------------------------- + Durations +--------------------------------------------------------------------------------------*/ + +bool kk_duration_is_zero(kk_duration_t x) { + return (x.seconds == 0 && x.attoseconds == 0); +} + +bool kk_duration_is_gt(kk_duration_t x, kk_duration_t y) { + kk_assert(x.attoseconds >= 0 && y.attoseconds >= 0); + return (x.seconds > y.seconds || (x.seconds == y.seconds && x.attoseconds > y.attoseconds)); +} + + #define KK_NSECS_PER_SEC KK_I64(1000000000) #define KK_ASECS_PER_NSEC KK_I64(1000000000) +#define KK_ASECS_PER_MSEC (1000000 * KK_ASECS_PER_NSEC) #define KK_ASECS_PER_SEC (KK_NSECS_PER_SEC * KK_ASECS_PER_NSEC) +kk_duration_t kk_duration_from_secs(int64_t secs) { + kk_duration_t d; + d.seconds = secs; + d.attoseconds = 0; + return d; +} + +kk_duration_t kk_duration_zero(void) { + return kk_duration_from_secs(0); +} + +kk_duration_t kk_duration_norm(kk_duration_t x) { + while (x.attoseconds < 0) { + x.seconds--; + x.attoseconds += KK_ASECS_PER_SEC; + } + while (x.attoseconds >= KK_ASECS_PER_SEC) { + x.seconds++; + x.attoseconds -= KK_ASECS_PER_SEC; + } + return x; +} + +kk_duration_t kk_duration_neg(kk_duration_t x) { + kk_duration_t d; + d.seconds = -x.seconds; + d.attoseconds = -x.attoseconds; + return kk_duration_norm(d); +} + +kk_duration_t kk_duration_add(kk_duration_t x, kk_duration_t y) { + kk_duration_t z; + z.seconds = x.seconds + y.seconds; + z.attoseconds = x.attoseconds + y.attoseconds; + return kk_duration_norm(z); +} + +kk_duration_t kk_duration_sub(kk_duration_t x, kk_duration_t y) { + return kk_duration_add(x, kk_duration_neg(y)); +} + +kk_duration_t kk_duration_from_nsecs(int64_t nsecs) { + kk_duration_t d; + d.seconds = nsecs / KK_NSECS_PER_SEC; + d.attoseconds = (nsecs % KK_NSECS_PER_SEC) * KK_ASECS_PER_NSEC; + return kk_duration_norm(d); +} + /*-------------------------------------------------------------------------------------------------- Timer ticks --------------------------------------------------------------------------------------------------*/ -kk_decl_export kk_secs_t kk_timer_ticks(kk_asecs_t* asecs, kk_context_t* ctx); -kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx); // in atto seconds - #ifdef WIN32 #include -static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { +static kk_duration_t kk_timer_ticks_prim(kk_context_t* ctx) { LARGE_INTEGER t; QueryPerformanceCounter(&t); if (ctx->timer_freq == 0) { @@ -31,13 +92,12 @@ static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { } kk_assert_internal(ctx->timer_freq != 0); // calculate in parts for precision - kk_secs_t secs = t.QuadPart / ctx->timer_freq; - int64_t frac = t.QuadPart % ctx->timer_freq; - if (asecs != NULL) { - int64_t resolution = KK_ASECS_PER_SEC / ctx->timer_freq; - *asecs = frac * resolution; - } - return secs; + kk_duration_t d; + d.seconds = t.QuadPart / ctx->timer_freq; + int64_t frac = t.QuadPart % ctx->timer_freq; + int64_t resolution = KK_ASECS_PER_SEC / ctx->timer_freq; + d.attoseconds = frac * resolution; + return kk_duration_norm(d); } #else @@ -50,7 +110,7 @@ static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { #endif // high res timer -static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { +static kk_duration_t kk_timer_ticks_prim(kk_context_t* ctx) { if (ctx->timer_freq == 0) { struct timespec tres = { 0, 0 }; clock_getres(CLOCK_MONOTONIC, &tres); @@ -63,65 +123,54 @@ static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { } struct timespec t; clock_gettime(CLOCK_MONOTONIC, &t); - if (asecs != NULL) { - *asecs = t.tv_nsec * KK_ASECS_PER_NSEC; - } - return t.tv_sec; + kk_duration_t d; + d.seconds = t.tv_sec; + d.attoseconds = t.tv_nsec * KK_ASECS_PER_NSEC; + return kk_duration_norm(d); } #else // low resolution timer #pragma message("using low-res timer on this platform") -static kk_secs_t kk_timer_ticks_prim(kk_asecs_t* asecs, kk_context_t* ctx) { +static kk_duration_t kk_timer_ticks_prim(kk_context_t* ctx) { if (ctx->timer_freq == 0) { ctx->timer_freq = (int64_t)CLOCKS_PER_SEC; if (ctx->timer_freq <= 0) { ctx->timer_freq = 1000; } } int64_t t = (int64_t)clock(); // calculate in parts for precision - int64_t secs = t / ctx->timer_freq; - int64_t frac = t % ctx->timer_freq; - if (asecs != NULL) { - int64_t resolution = KK_ASECS_PER_SEC / ctx->timer_freq; - *asecs = frac * resolution; - } - return secs; + kk_duration_t d; + d.seconds = t / ctx->timer_freq; + const int64_t frac = t % ctx->timer_freq; + const int64_t resolution = KK_ASECS_PER_SEC / ctx->timer_freq; + d.attoseconds = frac * resolution; + return kk_duration_norm(d); } #endif #endif -kk_decl_export kk_secs_t kk_timer_ticks(kk_asecs_t* atto_secs, kk_context_t* ctx) { - kk_asecs_t asecs; - kk_secs_t secs = kk_timer_ticks_prim(&asecs, ctx); +kk_decl_export kk_duration_t kk_timer_ticks(kk_context_t* ctx) { + const kk_duration_t d = kk_timer_ticks_prim(ctx); // init previous and delta - if (ctx->timer_prev.seconds == 0 && ctx->timer_prev.attoseconds == 0) { - ctx->timer_prev.seconds = secs; - ctx->timer_prev.attoseconds = asecs; - ctx->timer_delta.seconds = secs; - ctx->timer_delta.attoseconds = asecs; + if kk_unlikely(kk_duration_is_zero(ctx->timer_prev)) { + ctx->timer_prev = d; + ctx->timer_delta = d; } // check monotonicity - if (ctx->timer_prev.seconds > secs || (ctx->timer_prev.seconds == secs && ctx->timer_prev.attoseconds >= asecs)) { - // ouch, clock ran backward; add 1 nano second and adjust the delta - ctx->timer_delta.seconds = ctx->timer_prev.seconds - secs; - ctx->timer_delta.attoseconds = ctx->timer_prev.attoseconds - asecs - KK_NSECS_PER_SEC; // can be negative + else if kk_unlikely(kk_duration_is_gt(ctx->timer_prev, d)) { + // ouch, clock ran backward! + // we adjust the delta to return the previous time + 1ns to maintain monotonicity. + // that is the return value is: d - new_delta == timer_prev + 1ns + // and thus: new_delta = d - timer_prev - 1ns + ctx->timer_delta = kk_duration_sub(kk_duration_sub(d, ctx->timer_prev), kk_duration_from_nsecs(1)); } // save time in previous and adjust with the delta - ctx->timer_prev.seconds = secs; - ctx->timer_prev.attoseconds = asecs; - secs -= ctx->timer_delta.seconds; - asecs -= ctx->timer_delta.attoseconds; - if (asecs < 0) { - secs -= 1; - asecs += KK_ASECS_PER_SEC; - } - kk_assert_internal(secs >= 0 && asecs >= 0); - if (atto_secs != NULL) *atto_secs = asecs; - return secs; + ctx->timer_prev = d; + return kk_duration_sub(d, ctx->timer_delta); } kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx) { - kk_timer_ticks_prim(NULL, ctx); // initialize + kk_timer_ticks_prim(ctx); // initialize kk_assert_internal(ctx->timer_freq != 0); return (KK_ASECS_PER_SEC / ctx->timer_freq); } @@ -133,95 +182,89 @@ kk_decl_export kk_asecs_t kk_timer_resolution(kk_context_t* ctx) { #ifdef WIN32 #define KK_100NSECS_PER_SEC KK_I64(10000000) #define KK_UNIX_EPOCH KK_I64(11644473600) // seconds since 1601-01-01 UTC to 1970-01-01 (Unix epoch) -static kk_secs_t kk_time_unix_now_prim(kk_secs_t* atto_secs, kk_context_t* ctx) { +static kk_duration_t kk_time_unix_now_prim(kk_context_t* ctx) { FILETIME ft; GetSystemTimeAsFileTime(&ft); LARGE_INTEGER ti; ti.LowPart = ft.dwLowDateTime; ti.HighPart = (LONG)ft.dwHighDateTime; int64_t t = ti.QuadPart; // t is the time in 100 nano seconds intervals since 1601-01-01 UTC. - int64_t secs = (t / KK_100NSECS_PER_SEC) - KK_UNIX_EPOCH; - int64_t fsecs = (t % KK_100NSECS_PER_SEC); + kk_duration_t d; + d.seconds = (t / KK_100NSECS_PER_SEC) - KK_UNIX_EPOCH; + d.attoseconds = (t % KK_100NSECS_PER_SEC) * 100 * KK_ASECS_PER_NSEC; if (ctx->time_freq == 0) { // initialize ctx->time_freq = KK_100NSECS_PER_SEC; } // done - if (atto_secs != NULL) { - *atto_secs = fsecs * 100 * KK_ASECS_PER_NSEC; - } - return secs; + return kk_duration_norm(d); } #else #include #if defined(CLOCK_REALTIME) // high res time -static kk_secs_t kk_time_unix_now_prim(kk_asecs_t* asecs, kk_context_t* ctx) { +static kk_duration_t kk_time_unix_now_prim(kk_context_t* ctx) { if (ctx->time_freq==0) { struct timespec tres = { 0, 0 }; clock_getres(CLOCK_REALTIME, &tres); - if (tres.tv_sec == 0 && tres.tv_nsec > 0 && tres.tv_nsec <= KK_NSECS_PER_SEC && (tres.tv_nsec % KK_NSECS_PER_SEC) == 0) { + if (tres.tv_sec == 0 && tres.tv_nsec > 0 && tres.tv_nsec <= KK_NSECS_PER_SEC) { + kk_assert((KK_NSECS_PER_SEC % tres.tv_nsec) == 0); ctx->time_freq = (KK_NSECS_PER_SEC / tres.tv_nsec); } + else if (tres.tv_sec == 1 && tres.tv_nsec == 0) { + ctx->time_freq = 1; + } else { + kk_assert(false); // should never happen? ctx->time_freq = KK_NSECS_PER_SEC; } } struct timespec t; clock_gettime(CLOCK_REALTIME, &t); - if (asecs != NULL) { - *asecs = t.tv_nsec * KK_ASECS_PER_NSEC; - } - return t.tv_sec; + kk_duration_t d; + d.seconds = t.tv_sec; + d.attoseconds = t.tv_nsec * KK_ASECS_PER_NSEC; + return kk_duration_norm(d); } #else // portable 1s resolution time -static kk_secs_t kk_time_unix_now_prim(kk_asecs_t* asecs, kk_context_t* ctx) { +static kk_duration_t kk_time_unix_now_prim(kk_context_t* ctx) { if (ctx->time_freq == 0) { - ctx->time_freq = 1; // :-( + ctx->time_freq = 1; } time_t t; time(&t); - if (asecs != NULL) { - *asecs = 0; - } - return t; + kk_duration_t d; + d.seconds = t; + d.attoseconds = 0; + return kk_duration_norm(d); } #endif #endif -kk_decl_export kk_secs_t kk_time_unix_now(kk_asecs_t* atto_secs, kk_context_t* ctx) { - kk_asecs_t asecs; - kk_secs_t secs = kk_time_unix_now_prim(&asecs, ctx); - if ((ctx->time_unix_prev.seconds > secs || (ctx->time_unix_prev.seconds == secs && ctx->time_unix_prev.attoseconds >= asecs)) - // time is set backward! - && ((ctx->time_unix_prev.seconds - secs) <= 1 && - (ctx->time_unix_prev.seconds - secs)*KK_ASECS_PER_SEC + (ctx->time_unix_prev.attoseconds - asecs) <= KK_ASECS_PER_SEC) - // ((secs + frac + 1.0) > (ctx->time_unix_prev.seconds + ctx->time_unix_prev.second_fraction)) - // if it is less the 1 second we add a tiny increment as we assume it is due to leap second smearing - ) { +kk_decl_export kk_duration_t kk_time_unix_now(kk_context_t* ctx) { + kk_duration_t d = kk_time_unix_now_prim(ctx); + if (kk_duration_is_gt(ctx->time_unix_prev, d) + // time is set backward! + // if it is less then 1 second we add a tiny increment as we assume it is due to leap second smearing + // (so we ensure at least monotonicity during a leap second) + && !kk_duration_is_gt(ctx->time_unix_prev, kk_duration_add(d,kk_duration_from_secs(1))) ) + { // keep monotonic and allow to catch up - secs = ctx->time_unix_prev.seconds; - ctx->time_unix_prev.attoseconds += KK_ASECS_PER_NSEC; - asecs = ctx->time_unix_prev.attoseconds; - } - else { - // save previous time - ctx->time_unix_prev.seconds = secs; - ctx->time_unix_prev.attoseconds = asecs; + d = kk_duration_add(ctx->time_unix_prev, kk_duration_from_nsecs(1)); } - // done - if (atto_secs != NULL) { - *atto_secs = asecs; - } - return secs; + // save previous time + ctx->time_unix_prev = d; + return d; } kk_decl_export kk_asecs_t kk_time_resolution(kk_context_t* ctx) { - kk_time_unix_now_prim(NULL, ctx); // initialize + if (ctx->time_freq == 0) { + kk_time_unix_now_prim(ctx); // initialize + } kk_assert_internal(ctx->time_freq != 0); return (KK_ASECS_PER_SEC / ctx->time_freq); } diff --git a/kklib/src/vector.c b/kklib/src/vector.c index 89ca30205..925fd957f 100644 --- a/kklib/src/vector.c +++ b/kklib/src/vector.c @@ -14,10 +14,10 @@ void kk_vector_init_borrow(kk_vector_t _v, kk_ssize_t start, kk_box_t def, kk_context_t* ctx) { kk_assert_internal(start >= 0); kk_ssize_t length; - kk_box_t* v = kk_vector_buf_borrow(_v, &length); + kk_box_t* v = kk_vector_buf_borrow(_v, &length, ctx); // inline kk_box_dup and kk_box_drop for better performance if (kk_box_is_ptr(def)) { - kk_block_t* b = kk_ptr_unbox(def); + kk_block_t* b = kk_ptr_unbox(def, ctx); for (kk_ssize_t i = start; i < length; i++) { kk_block_dup(b); // todo: dup with `length` in one go? v[i] = def; @@ -33,12 +33,12 @@ void kk_vector_init_borrow(kk_vector_t _v, kk_ssize_t start, kk_box_t def, kk_co kk_vector_t kk_vector_realloc(kk_vector_t vec, kk_ssize_t newlen, kk_box_t def, kk_context_t* ctx) { kk_ssize_t len; - kk_box_t* src = kk_vector_buf_borrow(vec, &len); + kk_box_t* src = kk_vector_buf_borrow(vec, &len, ctx); kk_box_t* dest; kk_vector_t vdest = kk_vector_alloc_uninit(newlen, &dest, ctx); const kk_ssize_t n = (len > newlen ? newlen : len); for (kk_ssize_t i = 0; i < n; i++) { - dest[i] = kk_box_dup(src[i]); + dest[i] = kk_box_dup(src[i], ctx); } kk_vector_init_borrow(vdest, n, def, ctx); // set extra entries to default value kk_vector_drop(vec, ctx); @@ -46,22 +46,23 @@ kk_vector_t kk_vector_realloc(kk_vector_t vec, kk_ssize_t newlen, kk_box_t def, } kk_vector_t kk_vector_copy(kk_vector_t vec, kk_context_t* ctx) { - kk_ssize_t len = kk_vector_len_borrow(vec); - return kk_vector_realloc(vec, len, kk_box_null, ctx); + kk_ssize_t len = kk_vector_len_borrow(vec, ctx); + return kk_vector_realloc(vec, len, kk_box_null(), ctx); } -kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx) { - if (kk_likely(!kk_block_is_thread_shared(&r->_block))) { +kk_unit_t kk_ref_vector_assign_borrow(kk_ref_t _r, kk_integer_t idx, kk_box_t value, kk_context_t* ctx) { + struct kk_ref_s* r = kk_datatype_as_assert(struct kk_ref_s*, _r, KK_TAG_REF, ctx); + if kk_likely(!kk_block_is_thread_shared(&r->_block)) { // fast path kk_box_t b; b.box = kk_atomic_load_relaxed(&r->value); kk_vector_t v = kk_vector_unbox(b, ctx); - if(kk_unlikely(! kk_datatype_is_unique(v))) { + if kk_unlikely(!kk_datatype_is_unique(v,ctx)) { // the old v is dropped by kk_ref_set_borrow - v = kk_vector_copy(kk_vector_dup(v), ctx); - kk_ref_set_borrow(r, kk_vector_box(v, ctx), ctx); + v = kk_vector_copy(kk_vector_dup(v,ctx), ctx); + kk_ref_set_borrow(_r, kk_vector_box(v, ctx), ctx); } kk_ssize_t len; - kk_box_t* p = kk_vector_buf_borrow(v, &len); + kk_box_t* p = kk_vector_buf_borrow(v, &len, ctx); kk_ssize_t i = kk_integer_clamp_ssize_t_borrow(idx, ctx); kk_assert(i < len); kk_box_drop(p[i], ctx); diff --git a/kklib/test/main.c b/kklib/test/main.c index f1a50d9f2..1db1c8c20 100644 --- a/kklib/test/main.c +++ b/kklib/test/main.c @@ -30,7 +30,7 @@ struct __data1_list_s { kk_block_t _block; }; -define_singleton( static, struct __data1_list_s, __data1_singleton_Nil, (kk_tag_t)0) +define_singleton(static, struct __data1_list_s, __data1_singleton_Nil, (kk_tag_t)0) struct __data1_Cons { struct __data1_list_s _inherit; @@ -48,18 +48,18 @@ static __data1__list __data1__new_Cons(kk_box_t x, __data1__list tail, kk_contex } static struct __data1_Cons* __data1__as_Cons(__data1__list x) { assert(__data1__is_Cons(x)); - return kk_basetype_as(struct __data1_Cons*, x); + return (struct __data1_Cons*)(&x->_block); } -static msecs_t test_timing(const char* msg, size_t loops, void (*fun)(kk_integer_t,kk_integer_t), kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { +static msecs_t test_timing(const char* msg, size_t loops, void (*fun)(kk_integer_t, kk_integer_t), kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_unused(msg); msecs_t start = _clock_start(); for (size_t i = 0; i < loops; i++) { - fun(kk_integer_dup(x),kk_integer_dup(y)); + fun(kk_integer_dup(x, ctx), kk_integer_dup(y, ctx)); } msecs_t end = _clock_end(start); - kk_integer_drop(x,ctx); - kk_integer_drop(y,ctx); + kk_integer_drop(x, ctx); + kk_integer_drop(y, ctx); //printf("test %s, %zu iterations: %6.3f s\n", msg, loops, (double)(end)/1000.0); return end; } @@ -73,16 +73,16 @@ static intptr_t add(intptr_t x, intptr_t y, kk_context_t* ctx) { kk_unused(ctx); static intptr_t sub(intptr_t x, intptr_t y, kk_context_t* ctx) { kk_unused(ctx); return check(x - y); } static intptr_t mul(intptr_t x, intptr_t y, kk_context_t* ctx) { kk_unused(ctx); return check(x * y); } -static void testx(const char* name, iop* op, xop* opx, intptr_t i, intptr_t j, kk_context_t* ctx) { +static void testx(const char* name, iop* op, xop* opx, kk_intf_t i, kk_intf_t j, kk_context_t* ctx) { kk_integer_t x = _kk_new_integer(i); kk_integer_t y = _kk_new_integer(j); intptr_t k = _kk_integer_value(op(x, y, ctx)); intptr_t expect = opx(i, j, ctx); - printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", i, name, j, k, (k==expect ? "ok" : "FAIL"), expect, (k == 10 ? "(overflow)" : "")); + printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", (intptr_t)i, name, (intptr_t)j, k, (k == expect ? "ok" : "FAIL"), expect, (k == 10 ? "(overflow)" : "")); } -static void testb(const char* name, iop* op, kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_context_t* ctx ) { +static void testb(const char* name, iop* op, kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_context_t* ctx) { kk_integer_t k = (op(x, y, ctx)); - printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", _kk_integer_value(x), name, _kk_integer_value(y), _kk_integer_value(k), (_kk_integer_value(k)==_kk_integer_value(expect) ? "ok" : "FAIL"), _kk_integer_value(expect), (_kk_integer_value(k) == 43 ? "(overflow)" : "")); + printf("%16zx %s %16zx = %16zx: %4s (expected %zx) %s\n", (intptr_t)_kk_integer_value(x), name, (intptr_t)_kk_integer_value(y), (intptr_t)_kk_integer_value(k), (_kk_integer_value(k) == _kk_integer_value(expect) ? "ok" : "FAIL"), (intptr_t)_kk_integer_value(expect), (_kk_integer_value(k) == 43 ? "(overflow)" : "")); } static void test_op(const char* name, iop* op, xop* opx, kk_context_t* ctx) { testx(name, op, opx, KK_SMALLINT_MAX, 1, ctx); @@ -113,7 +113,7 @@ static void test(kk_context_t* ctx) { } static void test_add(kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_context_t* ctx) { - kk_integer_dup(x); kk_integer_dup(y); + kk_integer_dup(x, ctx); kk_integer_dup(y, ctx); kk_integer_print(x, ctx); printf(" + "); kk_integer_print(y, ctx); printf(" = "); kk_integer_t z = kk_integer_add(x, y, ctx); kk_integer_print(z, ctx); printf(", expected: "); @@ -122,7 +122,7 @@ static void test_add(kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_con } static void test_sub(kk_integer_t x, kk_integer_t y, kk_integer_t expect, kk_context_t* ctx) { - kk_integer_dup(x); kk_integer_dup(y); + kk_integer_dup(x, ctx); kk_integer_dup(y, ctx); kk_integer_print(x, ctx); printf(" - "); kk_integer_print(y, ctx); printf(" = "); kk_integer_t z = kk_integer_sub(x, y, ctx); kk_integer_print(z, ctx); printf(", expected: "); @@ -143,7 +143,7 @@ static void fibx(int n, kk_integer_t* x1, kk_integer_t* x2, kk_context_t* ctx) { kk_integer_t y1; kk_integer_t y2; fibx(n - 1, &y1, &y2, ctx); - *x2 = y1; kk_integer_dup(y1); + *x2 = y1; kk_integer_dup(y1, ctx); *x1 = kk_integer_add(y1, y2, ctx); } } @@ -151,7 +151,7 @@ static void fibx(int n, kk_integer_t* x1, kk_integer_t* x2, kk_context_t* ctx) { static kk_integer_t fib(int n, kk_context_t* ctx) { kk_integer_t y1; kk_integer_t y2; - fibx(n+1, &y1, &y2, ctx); + fibx(n + 1, &y1, &y2, ctx); kk_integer_drop(y2, ctx); return y1; } @@ -160,23 +160,23 @@ static kk_integer_t fib(int n, kk_context_t* ctx) { static void test_fib(int i, kk_context_t* ctx) { printf("fib %i = ", i); - kk_integer_print(fib(i,ctx), ctx); + kk_integer_print(fib(i, ctx), ctx); printf("\n"); } static void test_read(const char* s, kk_context_t* ctx) { printf("read %s = ", s); - kk_integer_print(kk_integer_from_str(s,ctx), ctx); + kk_integer_print(kk_integer_from_str(s, ctx), ctx); printf("\n"); } static void expect(bool b, bool exp) { kk_unused_release(b); kk_unused_release(exp); - assert(b==exp); + assert(b == exp); } static void expect_eq(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - kk_integer_dup(x); kk_integer_dup(y); + kk_integer_dup(x, ctx); kk_integer_dup(y, ctx); printf(" "); kk_integer_print(x, ctx); printf(" == "); kk_integer_print(y, ctx); bool eq = kk_integer_eq(x, y, ctx); printf(" %s\n", (eq ? "ok" : "FAIL")); @@ -189,36 +189,36 @@ static void test_cmp_pos(kk_context_t* ctx) { expect(kk_integer_gt(kk_integer_from_small(54), kk_integer_from_small(45), ctx), true); expect(kk_integer_gt(kk_integer_from_small(45), kk_integer_from_small(54), ctx), false); expect(kk_integer_gt(kk_integer_from_small(45), kk_integer_from_small(45), ctx), false); - expect(kk_integer_gt(kk_integer_from_str("5498765432109876",ctx), kk_integer_from_str("4598765432109876",ctx), ctx), true); - expect(kk_integer_gt(kk_integer_from_str("4598765432109876",ctx), kk_integer_from_str("5498765432109876",ctx), ctx),false); - expect(kk_integer_gt(kk_integer_from_str("4598765432109876",ctx), kk_integer_from_str("4598765432109876",ctx), ctx),false); + expect(kk_integer_gt(kk_integer_from_str("5498765432109876", ctx), kk_integer_from_str("4598765432109876", ctx), ctx), true); + expect(kk_integer_gt(kk_integer_from_str("4598765432109876", ctx), kk_integer_from_str("5498765432109876", ctx), ctx), false); + expect(kk_integer_gt(kk_integer_from_str("4598765432109876", ctx), kk_integer_from_str("4598765432109876", ctx), ctx), false); } static void test_addx(kk_context_t* ctx) { printf("addition\n"); - expect_eq(kk_integer_add(kk_integer_from_small(0),kk_integer_from_str("9844190321790980841789",ctx), ctx),kk_integer_from_str("9844190321790980841789",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("9844190321790980841789",ctx), kk_integer_from_small(0), ctx), kk_integer_from_str("9844190321790980841789",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_small(0), kk_integer_from_str("-9844190321790980841789",ctx), ctx), kk_integer_from_str("-9844190321790980841789",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-9844190321790980841789",ctx), kk_integer_from_small(0), ctx), kk_integer_from_str("-9844190321790980841789",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-9007199254740983",ctx), kk_integer_from_str("-9999999999999998",ctx), ctx), kk_integer_from_str("-19007199254740981",ctx),ctx); - - expect_eq(kk_integer_add(kk_integer_from_str("1234567890987654321",ctx),kk_integer_from_str("9876543210123456789",ctx), ctx),kk_integer_from_str("11111111101111111110",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("1234567890987654321",ctx),kk_integer_from_str("-9876543210123456789",ctx), ctx),kk_integer_from_str("-8641975319135802468",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-1234567890987654321",ctx),kk_integer_from_str("9876543210123456789",ctx), ctx),kk_integer_from_str("8641975319135802468",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-1234567890987654321",ctx),kk_integer_from_str("-9876543210123456789",ctx), ctx),kk_integer_from_str("-11111111101111111110",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("9876543210123456789",ctx),kk_integer_from_str("1234567890987654321",ctx), ctx),kk_integer_from_str("11111111101111111110",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("9876543210123456789",ctx),kk_integer_from_str("-1234567890987654321",ctx), ctx),kk_integer_from_str("8641975319135802468",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-9876543210123456789",ctx),kk_integer_from_str("1234567890987654321",ctx), ctx),kk_integer_from_str("-8641975319135802468",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-9876543210123456789",ctx),kk_integer_from_str("-1234567890987654321",ctx), ctx),kk_integer_from_str("-11111111101111111110",ctx),ctx); - - expect_eq(kk_integer_sub(kk_integer_from_str("1234567890987654321",ctx),kk_integer_from_str("9876543210123456789",ctx), ctx),kk_integer_from_str("-8641975319135802468",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("1234567890987654321",ctx),kk_integer_from_str("-9876543210123456789",ctx), ctx),kk_integer_from_str("11111111101111111110",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("-1234567890987654321",ctx),kk_integer_from_str("9876543210123456789",ctx), ctx),kk_integer_from_str("-11111111101111111110",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("-1234567890987654321",ctx),kk_integer_from_str("-9876543210123456789",ctx), ctx),kk_integer_from_str("8641975319135802468",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("9876543210123456789",ctx),kk_integer_from_str("1234567890987654321",ctx), ctx),kk_integer_from_str("8641975319135802468",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("9876543210123456789",ctx),kk_integer_from_str("-1234567890987654321",ctx), ctx),kk_integer_from_str("11111111101111111110",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("-9876543210123456789",ctx),kk_integer_from_str("1234567890987654321",ctx), ctx),kk_integer_from_str("-11111111101111111110",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("-9876543210123456789",ctx),kk_integer_from_str("-1234567890987654321",ctx), ctx),kk_integer_from_str("-8641975319135802468",ctx),ctx); + expect_eq(kk_integer_add(kk_integer_from_small(0), kk_integer_from_str("9844190321790980841789", ctx), ctx), kk_integer_from_str("9844190321790980841789", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("9844190321790980841789", ctx), kk_integer_from_small(0), ctx), kk_integer_from_str("9844190321790980841789", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_small(0), kk_integer_from_str("-9844190321790980841789", ctx), ctx), kk_integer_from_str("-9844190321790980841789", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-9844190321790980841789", ctx), kk_integer_from_small(0), ctx), kk_integer_from_str("-9844190321790980841789", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-9007199254740983", ctx), kk_integer_from_str("-9999999999999998", ctx), ctx), kk_integer_from_str("-19007199254740981", ctx), ctx); + + expect_eq(kk_integer_add(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("9876543210123456789", ctx), ctx), kk_integer_from_str("11111111101111111110", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("-9876543210123456789", ctx), ctx), kk_integer_from_str("-8641975319135802468", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("9876543210123456789", ctx), ctx), kk_integer_from_str("8641975319135802468", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("-9876543210123456789", ctx), ctx), kk_integer_from_str("-11111111101111111110", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("9876543210123456789", ctx), kk_integer_from_str("1234567890987654321", ctx), ctx), kk_integer_from_str("11111111101111111110", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("9876543210123456789", ctx), kk_integer_from_str("-1234567890987654321", ctx), ctx), kk_integer_from_str("8641975319135802468", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-9876543210123456789", ctx), kk_integer_from_str("1234567890987654321", ctx), ctx), kk_integer_from_str("-8641975319135802468", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-9876543210123456789", ctx), kk_integer_from_str("-1234567890987654321", ctx), ctx), kk_integer_from_str("-11111111101111111110", ctx), ctx); + + expect_eq(kk_integer_sub(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("9876543210123456789", ctx), ctx), kk_integer_from_str("-8641975319135802468", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("-9876543210123456789", ctx), ctx), kk_integer_from_str("11111111101111111110", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("9876543210123456789", ctx), ctx), kk_integer_from_str("-11111111101111111110", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("-9876543210123456789", ctx), ctx), kk_integer_from_str("8641975319135802468", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("9876543210123456789", ctx), kk_integer_from_str("1234567890987654321", ctx), ctx), kk_integer_from_str("8641975319135802468", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("9876543210123456789", ctx), kk_integer_from_str("-1234567890987654321", ctx), ctx), kk_integer_from_str("11111111101111111110", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("-9876543210123456789", ctx), kk_integer_from_str("1234567890987654321", ctx), ctx), kk_integer_from_str("-11111111101111111110", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("-9876543210123456789", ctx), kk_integer_from_str("-1234567890987654321", ctx), ctx), kk_integer_from_str("-8641975319135802468", ctx), ctx); } #define append10(s) s s s s s s s s s s @@ -238,41 +238,41 @@ static void test_carry(kk_context_t* ctx) { kk_integer_t last = kk_integer_from_small(1); for (intptr_t i = 2; i < 99; i++) { - kk_integer_dup(last); + kk_integer_dup(last, ctx); num = kk_integer_add(num, last, ctx); - kk_integer_dup(num); + kk_integer_dup(num, ctx); last = kk_integer_sub(num, last, ctx); - kk_integer_dup(num); - expect_eq(num,kk_integer_from_str(fibs[i], ctx),ctx); + kk_integer_dup(num, ctx); + expect_eq(num, kk_integer_from_str(fibs[i], ctx), ctx); } kk_integer_drop(num, ctx); kk_integer_drop(last, ctx); - expect_eq(kk_integer_add(kk_integer_from_str("9007199254740991",ctx),kk_integer_from_small(1), ctx), kk_integer_from_str("9007199254740992",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("999999999999999999999000000000000000000000",ctx),kk_integer_from_str("1000000000000000000000",ctx), ctx),kk_integer_from_str("1e42",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("1e20",ctx), kk_integer_from_str("9007199254740972",ctx), ctx), kk_integer_from_str("100009007199254740972",ctx),ctx); - expect_eq(kk_integer_add(kk_integer_from_str("-9007199254740983",ctx), kk_integer_from_str("-9999999999999998",ctx), ctx), kk_integer_from_str("-19007199254740981",ctx),ctx); + expect_eq(kk_integer_add(kk_integer_from_str("9007199254740991", ctx), kk_integer_from_small(1), ctx), kk_integer_from_str("9007199254740992", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("999999999999999999999000000000000000000000", ctx), kk_integer_from_str("1000000000000000000000", ctx), ctx), kk_integer_from_str("1e42", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("1e20", ctx), kk_integer_from_str("9007199254740972", ctx), ctx), kk_integer_from_str("100009007199254740972", ctx), ctx); + expect_eq(kk_integer_add(kk_integer_from_str("-9007199254740983", ctx), kk_integer_from_str("-9999999999999998", ctx), ctx), kk_integer_from_str("-19007199254740981", ctx), ctx); - expect_eq(kk_integer_sub(kk_integer_from_str(c, ctx), kk_integer_add(kk_integer_from_str(b, ctx), kk_integer_from_small(1), ctx), ctx), kk_integer_from_str("1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678899999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str(b, ctx), kk_integer_add(kk_integer_from_str(c, ctx), kk_integer_from_small(1), ctx), ctx), kk_integer_from_str("-1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678900000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("100000000000000000000000000000000000",ctx),kk_integer_from_str("999999999999999999",ctx), ctx), kk_integer_from_str("99999999999999999000000000000000001",ctx),ctx); - expect_eq(kk_integer_sub(kk_integer_from_str("10000000010000000",ctx), kk_integer_from_str("10000000",ctx), ctx), kk_integer_from_str("10000000000000000",ctx),ctx); + expect_eq(kk_integer_sub(kk_integer_from_str(c, ctx), kk_integer_add(kk_integer_from_str(b, ctx), kk_integer_from_small(1), ctx), ctx), kk_integer_from_str("1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678899999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999999", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str(b, ctx), kk_integer_add(kk_integer_from_str(c, ctx), kk_integer_from_small(1), ctx), ctx), kk_integer_from_str("-1234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678900000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("100000000000000000000000000000000000", ctx), kk_integer_from_str("999999999999999999", ctx), ctx), kk_integer_from_str("99999999999999999000000000000000001", ctx), ctx); + expect_eq(kk_integer_sub(kk_integer_from_str("10000000010000000", ctx), kk_integer_from_str("10000000", ctx), ctx), kk_integer_from_str("10000000000000000", ctx), ctx); } /* Borrow n */ static kk_integer_t factorial(kk_integer_t n, kk_context_t* ctx) { // 0 is a small integer and is not reference-counted - if (kk_integer_eq(n,kk_integer_from_small(0), ctx)) { + if (kk_integer_eq(n, kk_integer_from_small(0), ctx)) { return kk_integer_from_small(1); } // 1 is a small integer and is not reference-counted if (kk_integer_eq(n, kk_integer_from_small(1), ctx)) { return kk_integer_from_small(1); } - kk_integer_dup(n); - return kk_integer_mul(factorial(kk_integer_dec(kk_integer_dup(n), ctx), ctx),n, ctx); + kk_integer_dup(n, ctx); + return kk_integer_mul(factorial(kk_integer_dec(kk_integer_dup(n, ctx), ctx), ctx), n, ctx); } static void test_large(kk_context_t* ctx) { @@ -280,80 +280,80 @@ static void test_large(kk_context_t* ctx) { const char* hundredFactorial = "93326215443944152681699238856266700490715968264381621468592963895217599993229915608941463976156518286253697920827223758251185210916864000000000000000000000000"; const char* threeToTenThousand = "16313501853426258743032567291811547168121324535825379939348203261918257308143190787480155630847848309673252045223235795433405582999177203852381479145368112501453192355166224391025423628843556686559659645012014177448275529990373274425446425751235537341867387607813619937225616872862016504805593174059909520461668500663118926911571773452255850626968526251879139867085080472539640933730243410152186914328917354576854457274195562218013337745628502470673059426999114202540773175988199842487276183685299388927825296786440252999444785694183675323521704432195785806270123388382931770198990841300861506996108944782065015163410344894945809337689156807686673462563038164792190665340124344133980763205594364754963451564072340502606377790585114123814919001637177034457385019939060232925194471114235892978565322415628344142184842892083466227875760501276009801530703037525839157893875741192497705300469691062454369926795975456340236777734354667139072601574969834312769653557184396147587071260443947944862235744459711204473062937764153770030210332183635531818173456618022745975055313212598514429587545547296534609597194836036546870491771927625214352957503454948403635822345728774885175809500158451837389413798095329711993092101417428406774326126450005467888736546254948658602484494535938888656542746977424368385335496083164921318601934977025095780370104307980276356857350349205866078371806065542393536101673402017980951598946980664330391505845803674248348878071010412918667335823849899623486215050304052577789848512410263834811719236949311423411823585316405085306164936671137456985394285677324771775046050970865520893596151687017153855755197348199659070192954771308347627111052471134476325986362838585959552209645382089055182871854866744633737533217524880118401787595094060855717010144087136495532418544241489437080074716158404895914136451802032446707961058757633345691696743293869623745410870051851590672859347061212573446572045088465460616826082579731686004585218284333452396157730036306379421822435818001505905203918209206969662326706952623512427380240468784114535101496733983401240219840048956733689309620321613793757156727562461651933397540266795963865921590913322060572673349849253303397874242381960775337182730037783698708748781738419747698880321601186310506332869704931303076839444790968339306301273371014087248060946851793697973114432706759288546077622831002526800554849696867710280945946603669593797354642136622231192695027321229511912952940320879763123151760555959496961163141455688278842949587288399100273691880018774147568892650186152065335219113072582417699616901995530249937735219099786758954892534365835235843156112799728164123461219817343904782402517111603206575330527850752564642995318064985900815557979945885931124351303252811255254295797082281946658798705979077492469849644183166585950844953164726896146168297808178398470451561320526180542310840744843107469368959707726836608471817060598771730170755446473440774031371227437651048421606224757527085958515947273151027400662948161111284777828103531499488913672800783167888051177155427285103861736658069404797695900758820465238673970882660162285107599221418743657006872537842677883708807515850397691812433880561772652364847297019508025848964833883225165668986935081274596293983121864046277268590401580209059988500511262470167150495261908136688693861324081559046336288963037090312033522400722360882494928182809075406914319957044927504420797278117837677431446979085756432990753582588102440240611039084516401089948868433353748444104639734074519165067632941419347985624435567342072815910754484123812917487312938280670403228188813003978384081332242484646571417574404852962675165616101527367425654869508712001788393846171780457455963045764943565964887518396481296159902471996735508854292964536796779404377230965723361625182030798297734785854606060323419091646711138678490928840107449923456834763763114226000770316931243666699425694828181155048843161380832067845480569758457751090640996007242018255400627276908188082601795520167054701327802366989747082835481105543878446889896230696091881643547476154998574015907396059478684978574180486798918438643164618541351689258379042326487669479733384712996754251703808037828636599654447727795924596382283226723503386540591321268603222892807562509801015765174359627788357881606366119032951829868274617539946921221330284257027058653162292482686679275266764009881985590648534544939224296689791195355783205968492422636277656735338488299104238060289209390654467316291591219712866052661347026855261289381236881063068219249064767086495184176816629077103667131505064964190910450196502178972477361881300608688593782509793781457170396897496908861893034634895715117114601514654381347139092345833472226493656930996045016355808162984965203661519182202145414866559662218796964329217241498105206552200001"; - expect_eq(factorial(kk_integer_from_small(10), ctx),kk_integer_from_str(tenFactorial, ctx),ctx); - expect_eq(factorial(kk_integer_from_small(100), ctx),kk_integer_from_str(hundredFactorial, ctx),ctx); - expect_eq(kk_integer_pow(kk_integer_from_small(3),kk_integer_from_int(10000,ctx), ctx), kk_integer_from_str(threeToTenThousand, ctx),ctx); + expect_eq(factorial(kk_integer_from_small(10), ctx), kk_integer_from_str(tenFactorial, ctx), ctx); + expect_eq(factorial(kk_integer_from_small(100), ctx), kk_integer_from_str(hundredFactorial, ctx), ctx); + expect_eq(kk_integer_pow(kk_integer_from_small(3), kk_integer_from_int(10000, ctx), ctx), kk_integer_from_str(threeToTenThousand, ctx), ctx); // large multiply divide kk_integer_t x = kk_integer_from_str(hundredFactorial, ctx); - expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(x), kk_integer_dup(x), ctx),kk_integer_dup(x), ctx), x,ctx); + expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(x, ctx), kk_integer_dup(x, ctx), ctx), kk_integer_dup(x, ctx), ctx), x, ctx); x = kk_integer_from_str(threeToTenThousand, ctx); - expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(x), kk_integer_dup(x), ctx), kk_integer_dup(x), ctx), x,ctx); + expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(x, ctx), kk_integer_dup(x, ctx), ctx), kk_integer_dup(x, ctx), ctx), x, ctx); kk_integer_t y = kk_integer_from_str(hundredFactorial, ctx); x = kk_integer_from_str(threeToTenThousand, ctx); - expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(y), kk_integer_dup(x), ctx), y, ctx), x,ctx); + expect_eq(kk_integer_cdiv(kk_integer_mul(kk_integer_dup(y, ctx), kk_integer_dup(x, ctx), ctx), y, ctx), x, ctx); } static void test_cdiv(kk_context_t* ctx) { - expect_eq(kk_integer_cdiv(kk_integer_from_str("163500573666152634716420931676158",ctx), kk_integer_from_int(13579, ctx), ctx), kk_integer_from_str("12040693251797086288859336598",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("163500573666152634716420931676158",ctx), kk_integer_from_int(-13579, ctx), ctx), kk_integer_from_str("-12040693251797086288859336598",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("-163500573666152634716420931676158",ctx), kk_integer_from_int(13579, ctx), ctx), kk_integer_from_str("-12040693251797086288859336598",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("-163500573666152634716420931676158",ctx), kk_integer_from_int(-13579, ctx), ctx), kk_integer_from_str("12040693251797086288859336598",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("163500573666152634716420931676158", ctx), kk_integer_from_int(13579, ctx), ctx), kk_integer_from_str("12040693251797086288859336598", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("163500573666152634716420931676158", ctx), kk_integer_from_int(-13579, ctx), ctx), kk_integer_from_str("-12040693251797086288859336598", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("-163500573666152634716420931676158", ctx), kk_integer_from_int(13579, ctx), ctx), kk_integer_from_str("-12040693251797086288859336598", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("-163500573666152634716420931676158", ctx), kk_integer_from_int(-13579, ctx), ctx), kk_integer_from_str("12040693251797086288859336598", ctx), ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("1234567890987654321",ctx), kk_integer_from_str("132435465768798",ctx), ctx), kk_integer_from_str("9322",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("1234567890987654321",ctx), kk_integer_from_str("-132435465768798",ctx), ctx), kk_integer_from_str("-9322",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("-1234567890987654321",ctx), kk_integer_from_str("132435465768798",ctx), ctx), kk_integer_from_str("-9322",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("-1234567890987654321",ctx), kk_integer_from_str("-132435465768798",ctx), ctx), kk_integer_from_str("9322",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("132435465768798", ctx), ctx), kk_integer_from_str("9322", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("1234567890987654321", ctx), kk_integer_from_str("-132435465768798", ctx), ctx), kk_integer_from_str("-9322", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("132435465768798", ctx), ctx), kk_integer_from_str("-9322", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("-1234567890987654321", ctx), kk_integer_from_str("-132435465768798", ctx), ctx), kk_integer_from_str("9322", ctx), ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("786456456335437356436",ctx), kk_integer_from_str("-5423424653",ctx), ctx), kk_integer_from_str("-145011041298",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("-93453764643534523",ctx), kk_integer_from_str("-2342",ctx), ctx), kk_integer_from_str("39903400787162",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("10000000000000000",ctx), kk_integer_from_str("-10000000000000000",ctx), ctx), kk_integer_from_str("-1",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("786456456335437356436", ctx), kk_integer_from_str("-5423424653", ctx), ctx), kk_integer_from_str("-145011041298", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("-93453764643534523", ctx), kk_integer_from_str("-2342", ctx), ctx), kk_integer_from_str("39903400787162", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("10000000000000000", ctx), kk_integer_from_str("-10000000000000000", ctx), ctx), kk_integer_from_str("-1", ctx), ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("98789789419609840614360398703968368740365403650364036403645046",ctx), kk_integer_from_small(-1), ctx), kk_integer_from_str("-98789789419609840614360398703968368740365403650364036403645046",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("98789789419609840614360398703968368740365403650364036403645046", ctx), kk_integer_from_small(-1), ctx), kk_integer_from_str("-98789789419609840614360398703968368740365403650364036403645046", ctx), ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("98109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241",ctx),kk_integer_from_str("98109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241",ctx), ctx), kk_integer_from_str("1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("98109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241981098409840984091564810684565416840659648198410651068657103974645132104164354016450306480360340639740650049510942094209420974219704902741950491209742109742097421902740927404920974209298924909742022419810984098409840915648106845654168406596481984106510686571039746451321041643540164503064803603406397406500495109420942094209742197049027419504912097421097420974219027409274049209742092989249097420224198109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241", ctx), kk_integer_from_str("98109840984098409156481068456541684065964819841065106865710397464513210416435401645030648036034063974065004951094209420942097421970490274195049120974210974209742190274092740492097420929892490974202241", ctx), ctx), kk_integer_from_str("1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001", ctx), ctx); //expect_eq(kk_integer_cdiv(kk_integer_from_str(e),kk_integer_from_str(d)),kk_integer_from_str("100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("1e1050",ctx), kk_integer_from_str("1e1000",ctx), ctx), kk_integer_from_str("1e50",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("650891045068740450350436540352434350243346254305240433565403624570436542564034355230360437856406345450735366803660233645540323657640436735034636550432635454032364560324366403643455063652403346540263364032643454530236455402336455640363263405423565405623454062354540326564062306456432664546654436564364556406435460643646363545606345066534456065340165344065234064564",ctx), kk_integer_from_str("2634565230452364554234565062345452365450236455423654456253445652344565423655423655462534506253450462354056523445062535462534052654350426355023654540625344056203455402635454026435501635446643754664546780646476442344654465764466744566754436556406235454066354570657548036545465",ctx), ctx), kk_integer_from_str("247058238507527885509216194910087226997858456323482112332514020694766925604284002588230023",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("650891045068740450350436540352434350243346254305240433565403624570436542564034355230360437856406345450735366803660233645540323657640436735034636550432635454032364560324366403643455063652403346540263364032643454530236455402336455640363263405423565405623454062354540326564062306456432664546654436564364556406435460643646363545606345066534456065340165344065234064564000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000",ctx), kk_integer_from_str("2634565230452364554234565062345452365450236455423654456253445652344565423655423655462534506253450462354056523445062535462534052654350426355023654540625344056203455402635454026435501635446643754664546780646476442344654465764466744566754436556406235454066354570657548036545465000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000",ctx), ctx), kk_integer_from_str("247058238507527885509216194910087226997858456323482112332514020694766925604284002588230023",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("9999999999999900000000000000",ctx), kk_integer_from_str("999999999999990000001",ctx), ctx), kk_integer_from_str("9999999",ctx),ctx); - expect_eq(kk_integer_cdiv(kk_integer_from_str("1e9999",ctx), kk_integer_from_str("1e999",ctx), ctx), kk_integer_from_str("1e9000",ctx),ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("1e1050", ctx), kk_integer_from_str("1e1000", ctx), ctx), kk_integer_from_str("1e50", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("650891045068740450350436540352434350243346254305240433565403624570436542564034355230360437856406345450735366803660233645540323657640436735034636550432635454032364560324366403643455063652403346540263364032643454530236455402336455640363263405423565405623454062354540326564062306456432664546654436564364556406435460643646363545606345066534456065340165344065234064564", ctx), kk_integer_from_str("2634565230452364554234565062345452365450236455423654456253445652344565423655423655462534506253450462354056523445062535462534052654350426355023654540625344056203455402635454026435501635446643754664546780646476442344654465764466744566754436556406235454066354570657548036545465", ctx), ctx), kk_integer_from_str("247058238507527885509216194910087226997858456323482112332514020694766925604284002588230023", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("650891045068740450350436540352434350243346254305240433565403624570436542564034355230360437856406345450735366803660233645540323657640436735034636550432635454032364560324366403643455063652403346540263364032643454530236455402336455640363263405423565405623454062354540326564062306456432664546654436564364556406435460643646363545606345066534456065340165344065234064564000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000", ctx), kk_integer_from_str("2634565230452364554234565062345452365450236455423654456253445652344565423655423655462534506253450462354056523445062535462534052654350426355023654540625344056203455402635454026435501635446643754664546780646476442344654465764466744566754436556406235454066354570657548036545465000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000", ctx), ctx), kk_integer_from_str("247058238507527885509216194910087226997858456323482112332514020694766925604284002588230023", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("9999999999999900000000000000", ctx), kk_integer_from_str("999999999999990000001", ctx), ctx), kk_integer_from_str("9999999", ctx), ctx); + expect_eq(kk_integer_cdiv(kk_integer_from_str("1e9999", ctx), kk_integer_from_str("1e999", ctx), ctx), kk_integer_from_str("1e9000", ctx), ctx); } static void test_count(kk_context_t* ctx) { - expect_eq(kk_integer_count_digits(kk_integer_from_int(0, ctx), ctx), kk_integer_from_int(1, ctx),ctx); - expect_eq(kk_integer_count_digits(kk_integer_from_int(9999,ctx), ctx), kk_integer_from_int(4, ctx),ctx); - expect_eq(kk_integer_count_digits(kk_integer_from_int(70123,ctx), ctx), kk_integer_from_int(5, ctx),ctx); - expect_eq(kk_integer_count_digits(kk_integer_from_int(-70123, ctx), ctx), kk_integer_from_int(5, ctx),ctx); - expect_eq(kk_integer_count_digits(kk_integer_from_str("1234567890",ctx), ctx), kk_integer_from_int(10, ctx),ctx); - expect_eq(kk_integer_count_digits(kk_integer_neg(kk_integer_from_str(b, ctx), ctx), ctx), kk_integer_from_int(100, ctx),ctx); + expect_eq(kk_integer_count_digits(kk_integer_from_int(0, ctx), ctx), kk_integer_from_int(1, ctx), ctx); + expect_eq(kk_integer_count_digits(kk_integer_from_int(9999, ctx), ctx), kk_integer_from_int(4, ctx), ctx); + expect_eq(kk_integer_count_digits(kk_integer_from_int(70123, ctx), ctx), kk_integer_from_int(5, ctx), ctx); + expect_eq(kk_integer_count_digits(kk_integer_from_int(-70123, ctx), ctx), kk_integer_from_int(5, ctx), ctx); + expect_eq(kk_integer_count_digits(kk_integer_from_str("1234567890", ctx), ctx), kk_integer_from_int(10, ctx), ctx); + expect_eq(kk_integer_count_digits(kk_integer_neg(kk_integer_from_str(b, ctx), ctx), ctx), kk_integer_from_int(100, ctx), ctx); - expect_eq(kk_integer_ctz(kk_integer_from_int(0,ctx), ctx), kk_integer_from_int(0,ctx),ctx); - expect_eq(kk_integer_ctz(kk_integer_from_int(-9900, ctx), ctx), kk_integer_from_int(2,ctx),ctx); - expect_eq(kk_integer_ctz(kk_integer_from_int(70000,ctx), ctx), kk_integer_from_int(4,ctx),ctx); - expect_eq(kk_integer_ctz(kk_integer_from_str("100000000",ctx), ctx), kk_integer_from_int(8,ctx),ctx); - expect_eq(kk_integer_ctz(kk_integer_from_str("10000000000",ctx), ctx), kk_integer_from_int(10,ctx),ctx); - expect_eq(kk_integer_ctz(kk_integer_from_str("1000000000000000000",ctx), ctx), kk_integer_from_int(18,ctx),ctx); + expect_eq(kk_integer_ctz(kk_integer_from_int(0, ctx), ctx), kk_integer_from_int(0, ctx), ctx); + expect_eq(kk_integer_ctz(kk_integer_from_int(-9900, ctx), ctx), kk_integer_from_int(2, ctx), ctx); + expect_eq(kk_integer_ctz(kk_integer_from_int(70000, ctx), ctx), kk_integer_from_int(4, ctx), ctx); + expect_eq(kk_integer_ctz(kk_integer_from_str("100000000", ctx), ctx), kk_integer_from_int(8, ctx), ctx); + expect_eq(kk_integer_ctz(kk_integer_from_str("10000000000", ctx), ctx), kk_integer_from_int(10, ctx), ctx); + expect_eq(kk_integer_ctz(kk_integer_from_str("1000000000000000000", ctx), ctx), kk_integer_from_int(18, ctx), ctx); } static void test_pow10(kk_context_t* ctx) { - expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890",ctx),kk_integer_from_int(0,ctx), ctx), kk_integer_from_str("1234567890",ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_int(0,ctx), kk_integer_from_str("1234567890",ctx), ctx), kk_integer_from_int(0,ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_int(-1, ctx), kk_integer_from_str("12",ctx), ctx), kk_integer_from_str("-1e12",ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890",ctx), kk_integer_from_int(8,ctx), ctx), kk_integer_from_str("1234567890e8",ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_str("-1234567890",ctx), kk_integer_from_int(8,ctx), ctx), kk_integer_from_str("-1234567890e8",ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890",ctx), kk_integer_from_int(18,ctx), ctx), kk_integer_from_str("1234567890e18",ctx),ctx); - expect_eq(kk_integer_mul_pow10(kk_integer_from_int(1234,ctx), kk_integer_from_int(14,ctx), ctx), kk_integer_from_str("1234e14",ctx),ctx); - - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890",ctx), kk_integer_from_int(0,ctx), ctx), kk_integer_from_str("1234567890",ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_int(0,ctx), kk_integer_from_str("1234567890",ctx), ctx), kk_integer_from_int(0,ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("-1e13",ctx), kk_integer_from_str("12",ctx), ctx), kk_integer_from_str("-10",ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890",ctx), kk_integer_from_int(8,ctx), ctx), kk_integer_from_str("12",ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("-1234567890",ctx), kk_integer_from_int(8,ctx), ctx), kk_integer_from_str("-12",ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("9999999999",ctx), kk_integer_from_int(8,ctx), ctx), kk_integer_from_str("99",ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890",ctx), kk_integer_from_int(18,ctx), ctx), kk_integer_from_int(0,ctx),ctx); - expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234e14",ctx), kk_integer_from_int(14,ctx), ctx), kk_integer_from_str("1234",ctx),ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(0, ctx), ctx), kk_integer_from_str("1234567890", ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_int(0, ctx), kk_integer_from_str("1234567890", ctx), ctx), kk_integer_from_int(0, ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_int(-1, ctx), kk_integer_from_str("12", ctx), ctx), kk_integer_from_str("-1e12", ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(8, ctx), ctx), kk_integer_from_str("1234567890e8", ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_str("-1234567890", ctx), kk_integer_from_int(8, ctx), ctx), kk_integer_from_str("-1234567890e8", ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(18, ctx), ctx), kk_integer_from_str("1234567890e18", ctx), ctx); + expect_eq(kk_integer_mul_pow10(kk_integer_from_int(1234, ctx), kk_integer_from_int(14, ctx), ctx), kk_integer_from_str("1234e14", ctx), ctx); + + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(0, ctx), ctx), kk_integer_from_str("1234567890", ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_int(0, ctx), kk_integer_from_str("1234567890", ctx), ctx), kk_integer_from_int(0, ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("-1e13", ctx), kk_integer_from_str("12", ctx), ctx), kk_integer_from_str("-10", ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(8, ctx), ctx), kk_integer_from_str("12", ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("-1234567890", ctx), kk_integer_from_int(8, ctx), ctx), kk_integer_from_str("-12", ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("9999999999", ctx), kk_integer_from_int(8, ctx), ctx), kk_integer_from_str("99", ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234567890", ctx), kk_integer_from_int(18, ctx), ctx), kk_integer_from_int(0, ctx), ctx); + expect_eq(kk_integer_cdiv_pow10(kk_integer_from_str("1234e14", ctx), kk_integer_from_int(14, ctx), ctx), kk_integer_from_str("1234", ctx), ctx); } static kk_integer_t ia; @@ -369,16 +369,16 @@ static void init_nums(kk_context_t* ctx) { static kk_integer_t init_num(size_t digits, kk_context_t* ctx) { char* s = (char*)kk_malloc(digits + 1, ctx); for (size_t i = 0; i < digits; i++) { - s[i] = '0' + (9 - (i%10)); + s[i] = '0' + (9 - (i % 10)); } s[digits] = 0; - kk_integer_t x = kk_integer_from_str(s,ctx); - kk_free(s,ctx); + kk_integer_t x = kk_integer_from_str(s, ctx); + kk_free(s, ctx); return x; } static void test_mul(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { - kk_integer_t i = kk_integer_mul(x,y,ctx); + kk_integer_t i = kk_integer_mul(x, y, ctx); kk_integer_drop(i, ctx); } /* @@ -392,18 +392,18 @@ static void test_bitcount(void) { uint32_t values[] = { 1,0x80000000,0xFFFFFFFF,0xFFFF,0xFFFF0000,0x7FFFFFFF,0xFFFFFFFE, 0x7FFFFFFE, 0x80000001, 0 }; size_t i = 0; uint32_t v; - uint8_t l, t; + int l, t; do { v = values[i++]; l = kk_bits_clz32(v); t = kk_bits_ctz32(v); if (v == 0) assert((l + t) == 64); - printf("value: 0x%08x, ctz: %2u, clz: %2u\n", v, t, l); + printf("value: 0x%08x, ctz: %2d, clz: %2d\n", v, t, l); } while (v != 0); for (v = 1; v != 0; v <<= 1) { l = kk_bits_clz32(v); t = kk_bits_ctz32(v); - printf("value: 0x%08x, ctz: %2u, clz: %2u\n", v, t, l); + printf("value: 0x%08x, ctz: %2d, clz: %2d\n", v, t, l); assert((l + t) == 31); } } @@ -411,8 +411,8 @@ static void test_bitcount(void) { static void test_popcount(void) { printf("testing popcount..."); fflush(stdout); for (uint32_t i = 0; i < UINT32_MAX; i++) { - uint32_t c1 = kk_bits_generic_count32(i); - uint32_t c2 = kk_bits_count32(i); + int c1 = kk_bits_generic_popcount32(i); + int c2 = kk_bits_popcount32(i); if (c1 != c2) { assert(c1 == c2); abort(); @@ -427,8 +427,8 @@ static void test_popcount(void) { static void test_box_double(double dx, kk_context_t* ctx) { kk_box_t bx = kk_double_box(dx, ctx); - double e = kk_double_unbox(bx, ctx); - printf("value: %.20e, box-unbox to: %.20e, box: 0x%016zx\n", dx, e, bx.box); + double e = kk_double_unbox(bx, KK_BORROWED, ctx); + printf("value: %.20e, box-unbox to: %.20e, box: 0x%016zx\n", dx, e, (intptr_t)bx.box); assert(e == dx || (isnan(e) && isnan(dx))); } @@ -445,8 +445,8 @@ static void test_double(kk_context_t* ctx) { i = 0; do { dx = values[i++]; - test_box_double(dx,ctx); - test_box_double(nexttoward(dx,-HUGE_VALL), ctx); + test_box_double(dx, ctx); + test_box_double(nexttoward(dx, -HUGE_VALL), ctx); test_box_double(nexttoward(dx, HUGE_VALL), ctx); test_box_double(-dx, ctx); test_box_double(nexttoward(-dx, -HUGE_VALL), ctx); @@ -484,40 +484,40 @@ static void test_count10(kk_context_t* ctx) { { uint64_t u = 0; for (int i = 0; i < 22; i++) { - test_count10_64(u-1); + test_count10_64(u - 1); test_count10_64(u); - test_count10_64(u+1); - test_count10_64(u*9); - if (u==0) u = 1; + test_count10_64(u + 1); + test_count10_64(u * 9); + if (u == 0) u = 1; else u *= 10; } u = 1; for (int i = 0; i < 64; i++) { - test_count10_64(u-1); + test_count10_64(u - 1); test_count10_64(u); - test_count10_64(u+1); - test_count10_64(u*9); - if (u==0) u = 1; + test_count10_64(u + 1); + test_count10_64(u * 9); + if (u == 0) u = 1; else u <<= 1; } } { uint32_t u = 0; for (int i = 0; i < 11; i++) { - test_count10_32(u-1); + test_count10_32(u - 1); test_count10_32(u); - test_count10_32(u+1); - test_count10_32(u*9); - if (u==0) u = 1; + test_count10_32(u + 1); + test_count10_32(u * 9); + if (u == 0) u = 1; else u *= 10; } u = 1; for (int i = 0; i < 33; i++) { - test_count10_32(u-1); + test_count10_32(u - 1); test_count10_32(u); - test_count10_32(u+1); - test_count10_32(u*9); - if (u==0) u = 1; + test_count10_32(u + 1); + test_count10_32(u * 9); + if (u == 0) u = 1; else u <<= 1; } } @@ -528,10 +528,10 @@ static void test_random(kk_context_t* ctx) { uint32_t y = kk_srandom_uint32(ctx); const size_t N = 100000000; for (size_t i = 0; i < N; i++) { - y = kk_srandom_range_uint32(60000,ctx); + y = kk_srandom_range_uint32(60000, ctx); } msecs_t end = _clock_end(start); - printf("chacha20: final: 0x%x, %6.3fs\n", y, (double)end/1000.0); + printf("chacha20: final: 0x%x, %6.3fs\n", y, (double)end / 1000.0); } static void test_ovf(kk_context_t* ctx) { @@ -562,13 +562,115 @@ static void test_ovf(kk_context_t* ctx) { for (; i > 0; i -= delta) { n = kk_integer_dec(n, ctx); } msecs_t end = _clock_end(start); kk_integer_print(n, ctx); - printf("\nint-inc-dec: %6.3fs\n", (double)end/1000.0); + printf("\nint-inc-dec: %6.3fs\n", (double)end / 1000.0); +} + + +// Use double-double type for high precision conversion from duration to two doubles. +typedef struct kk_ddouble_s { + double hi; + double lo; +} kk_ddouble_t; + +static kk_ddouble_t kk_dd_sum(double x, double y) { + double z = x + y; + double diff = z - x; + double err = (x - (z - diff)) + (y - diff); + kk_ddouble_t dd = { z, err }; + return dd; +} + +static kk_ddouble_t kk_dd_quicksum(double x, double y) { + kk_assert(abs(x) >= abs(y)); + double z = x + y; + double err = y - (z - x); + kk_ddouble_t dd = { z, err }; + return dd; +} + +static kk_ddouble_t kk_dd_add(kk_ddouble_t x, kk_ddouble_t y) { + kk_ddouble_t z1 = kk_dd_sum(x.hi, y.hi); + kk_ddouble_t low = kk_dd_sum(x.lo, y.lo); + double e1 = z1.lo + low.hi; + kk_ddouble_t z2 = kk_dd_quicksum(z1.hi, e1); + double e2 = z2.lo + low.lo; + return kk_dd_quicksum(z2.hi, e2); +} + +static kk_ddouble_t kk_dd_from_int64(int64_t i, double scale) { + double x = ((double)kk_sar64(i,32) * 0x1p32) * scale; + double y = (double)((uint32_t)i) * scale; + return kk_dd_sum(x, y); +} + +#define KK_INT52_MAX ((KK_I64(1)<<51) - 1) +#define KK_INT52_MIN (-KK_INT52_MAX - 1) + +static kk_ddouble_t kk_dd_from_duration(kk_duration_t d) { + if kk_likely(d.attoseconds % KK_I64(1000000000) == 0) { + int64_t nsecs = (d.attoseconds / KK_I64(1000000000)); + if ((int32_t)nsecs == nsecs) { + double frac = ((double)nsecs * 1e-9); + double secs = 0; + if ((int32_t)secs == d.seconds) { + secs = (double)d.seconds; + } + else { + double sign = (d.seconds < 0 ? -1.0 : 1.0); + int64_t s = (d.seconds < 0 ? -d.seconds : d.seconds); + secs = sign * ((double)kk_shr64(s, 16) * 0x1p16); + frac = frac + (sign * (double)((uint16_t)s) * 1e18); + } + kk_ddouble_t dd; + dd.hi = secs; + dd.lo = frac; + return dd; + } + } + + if kk_likely((d.attoseconds % 1000) == 0 && // 1e-15 precision fits in 52 bits + d.seconds >= KK_INT52_MIN && d.seconds < KK_INT52_MAX) + { + // fast path when both components can be converted directly with full precision + kk_ddouble_t dd; + dd.hi = (double)(d.seconds); + dd.lo = (double)(d.attoseconds / 1000) * 1e-15; + return dd; + } + else { + // otherwise use ddouble arithmetic + return kk_dd_add(kk_dd_from_int64(d.seconds, 1.0), kk_dd_from_int64(d.attoseconds, 1e-18)); + } +} + + +void kk_duration_to_ddouble(kk_duration_t d, double* psecs, double* pfrac) { + kk_ddouble_t dd = kk_dd_from_duration(d); + int64_t secs = d.seconds; + int64_t asecs = d.attoseconds; + int sbits = 64 - kk_bits_clz64((uint64_t)secs); // bits used by the seconds + printf("duration: %20llus %lluas, sbits: %d, %20es . %fe, %.20es . %.20es\n", secs, asecs, sbits, (double)secs, (double)asecs * 1e-18, dd.hi, dd.lo); + + if (psecs != NULL) *psecs = dd.hi; + if (pfrac != NULL) *pfrac = dd.lo; +} + +void test_duration1(void) { + for (int64_t i = 1; i < (INT64_MAX/2); i <<= 1) { + kk_duration_t d; + d.seconds = i; + d.attoseconds = KK_I64(1000000000) * KK_I64(1000000000) - 1 - KK_I64(1000000000); + kk_duration_to_ddouble(d, NULL, NULL); + d.seconds += 1; + d.attoseconds = KK_I64(1000000000); + kk_duration_to_ddouble(d, NULL, NULL); + } } int main() { kk_context_t* ctx = kk_get_context(); - - test_fib(50,ctx); // 12586269025 + + test_fib(50, ctx); // 12586269025 test_fib(150, ctx); // 9969216677189303386214405760200 test_fib(300, ctx); // 22223224462942044552973989346190996720666693909649976499097960 test_read("123456789", ctx); @@ -586,10 +688,11 @@ int main() { test_ovf(ctx); test_count10(ctx); - //test_popcount(); test_bitcount(); + test_popcount(); //test_random(ctx); - + //test_duration1(); + /* init_nums(); for (int i = 100; i < 800; i+=50) { @@ -714,6 +817,6 @@ kk_integer_t test_add(kk_integer_t x) { int main(int argc, char** argv ) { kk_integer_t i = test_add(int_small(argc)); if (i) printf("uh oh\n"); - else printf("hello world!\n"); + else printf("hello world!\n"); } */ diff --git a/koka.cabal b/koka.cabal index 8ff5dc5b0..f1c50003a 100644 --- a/koka.cabal +++ b/koka.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack name: koka -version: 2.4.0 +version: 2.4.2 description: Please see the README on GitHub at homepage: https://github.com/koka-lang/koka#readme bug-reports: https://github.com/koka-lang/koka/issues @@ -53,11 +53,13 @@ executable koka Compiler.Module Compiler.Options Compiler.Package + Core.AnalysisCCtx Core.AnalysisMatch Core.AnalysisResume Core.BindingGroups Core.Borrowed Core.Check + Core.CheckFBIP Core.Core Core.CoreVar Core.CTail @@ -75,6 +77,7 @@ executable koka Core.Specialize Core.Uniquefy Core.UnReturn + Core.Unroll Interpreter.Command Interpreter.Interpret Kind.Assumption @@ -86,6 +89,7 @@ executable koka Kind.Kind Kind.Newtypes Kind.Pretty + Kind.Repr Kind.Synonym Kind.Unify Lib.JSON @@ -129,7 +133,7 @@ executable koka CPP OverloadedStrings ghc-options: -rtsopts -j8 - cpp-options: -DKOKA_MAIN="koka" -DKOKA_VARIANT="release" -DKOKA_VERSION="2.4.0" -DREADLINE=0 + cpp-options: -DKOKA_MAIN="koka" -DKOKA_VARIANT="release" -DKOKA_VERSION="2.4.2" -DREADLINE=0 include-dirs: src/Platform/cpp/Platform c-sources: @@ -148,11 +152,11 @@ executable koka , process , text , time + default-language: Haskell2010 if os(windows) cpp-options: -DWINDOWS if os(darwin) cpp-options: -DDARWIN - default-language: Haskell2010 test-suite koka-test type: exitcode-stdio-1.0 @@ -177,7 +181,7 @@ test-suite koka-test , mtl , parsec , process - , regex-compat-tdfa + , regex-compat >=0.95.2.1 , text , time default-language: Haskell2010 diff --git a/lib/std/core.kk b/lib/std/core.kk index 65d469ced..d23a94a23 100644 --- a/lib/std/core.kk +++ b/lib/std/core.kk @@ -20,7 +20,6 @@ pub import std/core/hnd pub infixr 80 (^) pub infixl 70 (*), (%), (/), cdiv, cmod -pub infixr 60 (++) pub infixl 60 (+), (-) pub infix 40 (!=), (==), (<=), (>=), (<), (>) // prefix (!), (-) @@ -113,10 +112,10 @@ pub fun const( default : a ) : total (( x : b ) -> a) // Standard Data types // ---------------------------------------------------------------------------- -pub fun int( b : bool ) : int +pub fip fun int( b : bool ) : int if b then 1 else 0 -pub fun mbint( m : maybe ) : int +pub fip fun mbint( m : maybe ) : int match m Nothing -> 0 Just(i) -> i @@ -185,7 +184,7 @@ pub fun map( e : either, f : b -> e c ) : e either // by a list (`Cons`). pub type list // The empty list. - con Nil + con Nil // note: must come first; see Core/Core.hs // A ``head`` element followed by the ``tail`` of the list. con Cons(head:a, tail : list ) @@ -217,7 +216,7 @@ pub fun is-empty( xs : list ) : bool pub co type stream con Next(head:a, tail: stream ) -pub fun int( x : order ) : int +pub fip fun int( x : order ) : int match x Lt -> -1 Eq -> 0 @@ -687,110 +686,110 @@ pub fun any( xs : list, predicate : a -> e bool ) : e bool // Characters // ---------------------------------------------------------------------------- -pub inline extern (==) : (char,char) -> bool +pub inline fip extern (==) : (char,char) -> bool inline "(#1 == #2)" js inline "(#1 === #2)" -pub inline extern (!=) : (char,char) -> bool +pub inline fip extern (!=) : (char,char) -> bool inline "(#1 != #2)" js inline "(#1 !== #2)" -pub inline extern (<=) : (char,char) -> bool +pub inline fip extern (<=) : (char,char) -> bool inline "(#1 <= #2)" -pub inline extern (>=) : (char,char) -> bool +pub inline fip extern (>=) : (char,char) -> bool inline "(#1 >= #2)" -pub inline extern (<) : (char,char) -> bool +pub inline fip extern (<) : (char,char) -> bool inline "(#1 < #2)" -pub inline extern (>) : (char,char) -> bool +pub inline fip extern (>) : (char,char) -> bool inline "(#1 > #2)" -pub fun compare( x : char, y : char ) : order +pub fip fun compare( x : char, y : char ) : order if x < y then Lt elif x > y then Gt else Eq // Convert a character to its unicode code point -pub inline extern int : (char) -> int +pub inline fip extern int : (char) -> int inline "#1" c "kk_integer_from_int" cs inline "new BigInteger(#1)" // Convert a unicode code point to a character -pub inline extern char( i : int) : char +pub inline fip extern char( i : int) : char inline "(#1)" c "kk_integer_clamp32" cs inline "Primitive.IntToInt32(#1)" // Add two character code points -pub fun (+)(c : char, d : char) : total char +pub fip fun (+)(c : char, d : char) : total char (c.int + d.int).char // Substract two character codePoints -pub fun (-)(c : char, d : char) : total char +pub fip fun (-)(c : char, d : char) : total char (c.int - d.int).char // Is the character a lower-case ASCII character ? -pub fun is-lower( c : char ) : bool +pub fip fun is-lower( c : char ) : bool c >= 'a' && c <= 'z' // Is the character an upper-case ASCII character ? -pub fun is-upper( c : char ) : bool +pub fip fun is-upper( c : char ) : bool c >= 'A' && c <= 'Z' // Is the character an ASCII digit ? -pub fun is-digit( c : char ) : bool +pub fip fun is-digit( c : char ) : bool c >= '0' && c <= '9' // Is the character an ASCII hexa-decimal digit ? -pub fun is-hex-digit( c : char ) : bool +pub fip fun is-hex-digit( c : char ) : bool c.is-digit || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F') // Is the character an ASCII letter is- -pub fun is-alpha( c : char ) : bool +pub fip fun is-alpha( c : char ) : bool c.is-lower || c.is-upper // Is the character ASCII letter or digit? -pub fun is-alpha-num( c : char ) : bool +pub fip fun is-alpha-num( c : char ) : bool c.is-alpha || c.is-digit // Is the character an ASCII character, e.g. `c <= '\x7F'` ? -pub fun is-ascii( c : char ) : bool +pub fip fun is-ascii( c : char ) : bool c <= '\x7F' // Is the character an ASCII control character, e.g. `c < ' '` ? -pub fun is-control( c : char ) : bool +pub fip fun is-control( c : char ) : bool c < ' ' // Tests if a character is an element of `" \t\n\r"` -pub fun is-white( c : char ) : bool +pub fip fun is-white( c : char ) : bool c == ' ' || c == '\t' || c == '\n' || c == '\r' // ---------------------------------------------------------------------------- // Booleans // ---------------------------------------------------------------------------- -pub fun (==)( x : bool, y : bool) : bool +pub fip fun (==)( x : bool, y : bool) : bool if x then y else !y -pub fun (!=)( x : bool, y : bool) : bool +pub fip fun (!=)( x : bool, y : bool) : bool if x then !y else y -pub fun (<)( x : bool, y : bool) : bool +pub fip fun (<)( x : bool, y : bool) : bool (!x && y) -pub fun (<=)( x : bool, y : bool) : bool +pub fip fun (<=)( x : bool, y : bool) : bool !(x > y) -pub fun (>)( x : bool, y : bool) : bool +pub fip fun (>)( x : bool, y : bool) : bool (x && !y) -pub fun (>=)( x : bool, y : bool) : bool +pub fip fun (>=)( x : bool, y : bool) : bool !(x < y) -pub fun compare( x : bool, y : bool) : order +pub fip fun compare( x : bool, y : bool) : order if x < y then Lt elif x > y then Gt else Eq @@ -805,79 +804,79 @@ pub fun maybe( b : bool ) : maybe<()> // ---------------------------------------------------------------------------- // Compare two integers -pub inline extern compare(^x : int, ^y : int) : order +pub inline fip extern compare(^x : int, ^y : int) : order c inline "kk_int_as_order(kk_integer_cmp_borrow(#1,#2,kk_context()),kk_context())" cs "Primitive.IntCompare" js "$std_core._int_compare" // Are two integers equal? -pub inline extern (==)(^x : int, ^y : int) : bool +pub inline fip extern (==)(^x : int, ^y : int) : bool c "kk_integer_eq_borrow" cs inline "(#1 == #2)" js "$std_core._int_eq" // Are two integers not equal? -pub inline extern (!=)(^x : int, ^y : int) : bool +pub inline fip extern (!=)(^x : int, ^y : int) : bool c "kk_integer_neq_borrow" cs inline "(#1 != #2)" js "$std_core._int_ne" // Is the first integer smaller or equal to the second? -pub inline extern (<=)(^x : int, ^y : int) : bool +pub inline fip extern (<=)(^x : int, ^y : int) : bool c "kk_integer_lte_borrow" cs inline "(#1 <= #2)" js "$std_core._int_le" // Is the first integer greater or equal to the second? -pub inline extern (>=)(^x : int, ^y : int) : bool +pub inline fip extern (>=)(^x : int, ^y : int) : bool c "kk_integer_gte_borrow" cs inline "(#1 >= #2)" js "$std_core._int_ge" // Is the first integer smaller than the second? -pub inline extern (<)(^x : int, ^y : int) : bool +pub inline fip extern (<)(^x : int, ^y : int) : bool c "kk_integer_lt_borrow" cs inline "(#1 < #2)" js "$std_core._int_lt" // Is the first integer greater than the second? -pub inline extern (>)(^x : int, ^y : int) : bool +pub inline fip extern (>)(^x : int, ^y : int) : bool c "kk_integer_gt_borrow" cs inline "(#1 > #2)" js "$std_core._int_gt" -inline extern int-add : (int,int) -> int +inline fip extern int-add : (int,int) -> int c "kk_integer_add" cs inline "(#1 + #2)" js "$std_core._int_add" // Add two integers. -pub fun (+)(x : int, y : int ) : int +pub fip fun (+)(x : int, y : int ) : int int-add(x,y) -inline extern int-sub : (int,int) -> int +inline fip extern int-sub : (int,int) -> int c "kk_integer_sub" cs inline "(#1 - #2)" js "$std_core._int_sub" // Substract two integers. -pub fun (-)(x : int, y : int ) : int +pub fip fun (-)(x : int, y : int ) : int int-sub(x,y) // Multiply two integers. -pub inline extern (*) : (int,int) -> int +pub inline fip extern (*) : (int,int) -> int c "kk_integer_mul" cs inline "(#1 * #2)" js "$std_core._int_mul" // Euclidean-0 division of two integers. See also `divmod:(x : int, y : int) -> (int,int)`. -pub inline extern (/)(x:int,y:int) : int +pub inline fip extern (/)(x:int,y:int) : int c "kk_integer_div" cs "Primitive.IntDiv" js "$std_core._int_div" // Euclidean modulus of two integers; always a non-negative number. See also `divmod:(x : int, y : int) -> (int,int)`. -pub inline extern (%) : (int,int) -> int +pub inline fip extern (%) : (int,int) -> int c "kk_integer_mod" cs "Primitive.IntMod" js "$std_core._int_mod" @@ -900,92 +899,92 @@ pub inline extern (%) : (int,int) -> int // // See also _Division and modulus for computer scientists, Daan Leijen, 2001_ for further information // available at: . -pub inline extern divmod(x:int,y:int) : (int,int) +pub inline fip extern divmod(x:int,y:int) : (int,int) c "kk_integer_div_mod_tuple" cs "Primitive.IntDivMod" js "$std_core._int_divmod" -pub fun negate(i : int) : int +pub fip fun negate(i : int) : int ~i // Negate an integer. -pub inline extern (~)(i:int) : int +pub inline fip extern (~)(i:int) : int c "kk_integer_neg" cs inline "(-#1)" js "$std_core._int_negate" // Convert an integer to a `:float64`. May return `nan` if the integer is too large to represent as a `:float64`. -pub inline extern float64( i : int) : float64 +pub inline fip extern float64( i : int) : float64 c "kk_integer_as_double" cs "Primitive.IntToDouble" js "$std_core._int_to_double" // Convert an integer to a `:float32`. May return `nan` if the integer is too large to represent as a `:float32`. -pub inline extern float32( i : int) : float32 +pub inline fip extern float32( i : int) : float32 c "kk_integer_as_float" cs "Primitive.IntToFloat" js "$std_core._int_to_float" // Is this an odd integer? -pub inline extern is-odd( i : int ) : bool +pub inline fip extern is-odd( i : int ) : bool c "kk_integer_is_odd" cs inline "!(#1.IsEven)" js "$std_core._int_isodd" // Is this equal to zero? -pub inline extern is-zero( ^x : int) : bool +pub inline fip extern is-zero( ^x : int) : bool c inline "kk_integer_is_zero_borrow(#1)" cs inline "(#1.IsZero)" js "$std_core._int_iszero" // Return the absolute value of an integer. -pub inline extern abs(i : int) : int +pub inline fip extern abs(i : int) : int c "kk_integer_abs" cs "BigInteger.Abs" js "$std_core._int_abs" -pub fun inc( i : int ) : int +pub fip fun inc( i : int ) : int i + 1 -pub fun dec( i : int ) : int +pub fip fun dec( i : int ) : int i - 1 // Calculate `10^exp` -pub fun exp10( exp : int ) : int +pub fip fun exp10( exp : int ) : int 1.mul-exp10(exp) // Raise an integer `i` to the power of `exp`. -pub extern pow( i : int, exp : int ) : int +pub fip extern pow( i : int, exp : int ) : int c "kk_integer_pow" cs "Primitive.IntPow" js "_int_pow" // Raise an integer `i` to the power of `exp`. -pub fun (^)(i : int, exp : int ) : int +pub fip fun (^)(i : int, exp : int ) : int pow(i,exp) // Calculate `2^exp`. -pub fun exp2( exp : int ) : int +pub fip fun exp2( exp : int ) : int pow(2,exp) // Return the number of ending `0` digits of `i`. Return `0` when `i==0`. -pub extern is-exp10( i : int ) : int +pub fip extern is-exp10( i : int ) : int c "kk_integer_ctz" cs "Primitive.IntCountPow10" js "_int_count_pow10" // Return the number of decimal digits of `i`. Return `0` when `i==0`. -pub extern count-digits( i : int ) : int +pub fip extern count-digits( i : int ) : int c "kk_integer_count_digits" cs "Primitive.IntCountDigits" js "_int_count_digits" -pub extern mul-exp10( i : int, n : int ) : int +pub fip extern mul-exp10( i : int, n : int ) : int c "kk_integer_mul_pow10" cs "Primitive.IntMulPow10" js "_int_mul_pow10" -pub extern cdiv-exp10( i : int, n : int ) : int +pub fip extern cdiv-exp10( i : int, n : int ) : int c "kk_integer_cdiv_pow10" cs "Primitive.IntCDivPow10" js "_int_cdiv_pow10" @@ -1001,28 +1000,28 @@ pub fun divmod-exp10( i : int, n : int ) : (int,int) if !cr.is-neg then (cq,cr) else (cq.dec, cr + exp10(n)) // Is this an even integer? -pub fun is-even(i:int) : bool +pub fip fun is-even(i:int) : bool !is-odd(i) // Is the integer positive (stricly greater than zero) -pub fun is-pos(i : int ) : bool - i.sign == Gt +pub fip fun is-pos(i : int ) : bool + i > 0 // Is the integer negative (stricly smaller than zero) -pub fun is-neg(i : int ) : bool - i.sign == Lt +pub fip fun is-neg(i : int ) : bool + i < 0 -pub inline extern sign( ^i : int ) : order - c inline "kk_int_as_order(kk_integer_signum_borrow(#1),kk_context())" +pub inline fip extern sign( ^i : int ) : order + c inline "kk_int_as_order(kk_integer_signum_borrow(#1,kk_context()),kk_context())" cs "Primitive.IntSign" js "$std_core._int_sign" // Return the minimum of two integers -pub fun min( i : int, j : int ) : int +pub fip fun min( i : int, j : int ) : int if i <= j then i else j // Return the maximum of two integers -pub fun max( i : int, j : int ) : int +pub fip fun max( i : int, j : int ) : int if i >= j then i else j // Returns the smallest element of a list of integers (or `default` (=`0`) for the empty list) @@ -1055,59 +1054,65 @@ pub fun fold-int( start : int, end : int, init : a, f : (int,a) -> e a ) : e a pub fun fold-int( upto : int, init : a, f : (int,a) -> e a ) : e a fold-int( 0, upto.dec, init, f ) + +pub fun fold-while-int( start : int, end : int, init : a, f : (int,a) -> e maybe ) : e a + if start >= end then init else + match f(start,init) + Just(x) -> fold-while-int(unsafe-decreasing(start.inc), end, x, f) + Nothing -> init + // ---------------------------------------------------------------------------- // 32-bit integers // Just define the operations needed for defining the std/core interface but // don't export any definitions here. Full operations are defined in `std/int32`. // ---------------------------------------------------------------------------- -// Convert an `:int32` to an `:int`. -pub inline extern int( i : int32 ) : int +// Convert an `:int32` to an `:int`. +pub inline fip extern int( i : int32 ) : int c "kk_integer_from_int" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int32" // Convert an integer to an `:int32`. The number is _clamped_ to the maximal or minimum `:int32` // value if it is outside the range of an `:int32`. -pub extern int32( i : int) : int32 +pub fip extern int32( i : int) : int32 c "kk_integer_clamp32" cs "Primitive.IntToInt32" js "$std_core._int_clamp32" // Convenient shorthand to `int32`, e.g. `1234.i32` -pub inline fun i32( i : int ) : int32 +pub inline fip fun i32( i : int ) : int32 i.int32 - // Minimal set of operations that we need in `std/core`. -inline extern (<=) : (int32,int32) -> bool +inline fip extern (<=) : (int32,int32) -> bool inline "(#1 <= #2)" js inline "(#1 <= #2)" -inline extern (<) : (int32,int32) -> bool +inline fip extern (<) : (int32,int32) -> bool inline "(#1 < #2)" js inline "(#1 < #2)" -inline extern (+) : (int32,int32) -> int32 +inline fip extern (+) : (int32,int32) -> int32 inline "(#1 + #2)" js inline "((#1 + #2)|0)" -inline extern (-) : (int32,int32) -> int32 +inline fip extern (-) : (int32,int32) -> int32 inline "(#1 - #2)" js inline "((#1 - #2)|0)" -inline extern is-pos( i : int32 ) : bool +inline fip extern is-pos( i : int32 ) : bool inline "(#1>0)" -inline extern is-neg( i : int32 ) : bool +inline fip extern is-neg( i : int32 ) : bool inline "(#1<0)" -fun incr( i : int32 ) : int32 +fip fun incr( i : int32 ) : int32 i + 1.int32 -fun decr( i : int32 ) : int32 +fip fun decr( i : int32 ) : int32 i - 1.int32 // ---------------------------------------------------------------------------- @@ -1118,49 +1123,49 @@ fun decr( i : int32 ) : int32 // Convert an integer to an `:ssize_t`. The number is _clamped_ to the maximal or minimum `:ssize_t` // value if it is outside the range of an `:ssize_t`. -pub extern ssize_t( i : int) : ssize_t +pub fip extern ssize_t( i : int) : ssize_t c "kk_integer_clamp_ssize_t" cs "Primitive.IntToInt32" js "$std_core._int_clamp32" // Convert an `:ssize_t` to an `:int`. -pub inline extern int( i : ssize_t ) : int +pub inline fip extern int( i : ssize_t ) : int c "kk_integer_from_ssize_t" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int32" // Minimal set of operations that we need in `std/core`. -inline extern (<=) : (ssize_t,ssize_t) -> bool +inline fip extern (<=) : (ssize_t,ssize_t) -> bool inline "(#1 <= #2)" -inline extern (>=) : (ssize_t,ssize_t) -> bool +inline fip extern (>=) : (ssize_t,ssize_t) -> bool inline "(#1 >= #2)" -inline extern (<) : (ssize_t,ssize_t) -> bool +inline fip extern (<) : (ssize_t,ssize_t) -> bool inline "(#1 < #2)" -inline extern (+) : (ssize_t,ssize_t) -> ssize_t +inline fip extern (+) : (ssize_t,ssize_t) -> ssize_t inline "(#1 + #2)" js inline "((#1 + #2)|0)" -inline extern (-) : (ssize_t,ssize_t) -> ssize_t +inline fip extern (-) : (ssize_t,ssize_t) -> ssize_t inline "(#1 - #2)" js inline "((#1 - #2)|0)" -inline extern is-pos( i : ssize_t ) : bool +inline fip extern is-pos( i : ssize_t ) : bool inline "(#1 > 0)" -inline extern is-neg( i : ssize_t ) : bool +inline fip extern is-neg( i : ssize_t ) : bool inline "(#1 < 0)" -extern is-zero( i : ssize_t ) : bool +fip extern is-zero( i : ssize_t ) : bool inline "(#1 == 0)" js inline "(#1 === 0)" -extern decr(i : ssize_t ) : ssize_t +fip extern decr(i : ssize_t ) : ssize_t inline "(#1 - 1)" -extern incr(i : ssize_t ) : ssize_t +fip extern incr(i : ssize_t ) : ssize_t inline "(#1 + 1)" @@ -1169,13 +1174,13 @@ extern incr(i : ssize_t ) : ssize_t // ---------------------------------------------------------------------------- // clamp an `:int` to fit in an `:int8`. -pub extern int8( i : int) : int8 +pub fip extern int8( i : int) : int8 c "kk_integer_clamp_int8" cs "Primitive.IntToInt8" js "$std_core._int_clamp8" // Convert an `:int8` to an `:int`. -pub inline extern int( i : int8 ) : int +pub inline fip extern int( i : int8 ) : int c "kk_integer_from_int8" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int32" @@ -1183,13 +1188,13 @@ pub inline extern int( i : int8 ) : int // clamp an `:int` to fit in an `:int8` but interpret the `:int` as an unsigned 8-bit value, // and clamp between 0 and 255. -pub extern uint8( i : int) : int8 +pub fip extern uint8( i : int) : int8 c "kk_integer_clamp_byte" cs "Primitive.IntToUInt8" js "$std_core._int_clamp_byte" // Convert an `:int8` to an `:int` but interpret the `:int8` as an unsigned 8-bit value between 0 and 255. -pub inline extern uint( i : int8 ) : int +pub inline fip extern uint( i : int8 ) : int c "kk_integer_from_uint8" cs inline "(new BigInteger(#1 >= 0 ? #1 : 256 + #1))" js "$std_core._int_from_int32" @@ -1200,13 +1205,13 @@ pub inline extern uint( i : int8 ) : int // ---------------------------------------------------------------------------- // clamp an `:int` to fit in an `:int16`. -pub extern int16( i : int) : int16 +pub fip extern int16( i : int) : int16 c "kk_integer_clamp_int16" cs "Primitive.IntToInt16" js "$std_core._int_clamp16" // Convert an `:int16` to an `:int`. -pub inline extern int( i : int16 ) : int +pub inline fip extern int( i : int16 ) : int c "kk_integer_from_int16" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int32" @@ -1217,19 +1222,19 @@ pub inline extern int( i : int16 ) : int // ---------------------------------------------------------------------------- // clamp an `:int` to fit in an `:int64_t`. -pub extern int64( i : int) : int64 +pub fip extern int64( i : int) : int64 c "kk_integer_clamp64" cs "Primitive.IntToInt64" js "$std_core._int_clamp64" // Convert an `:int64_t` to an `:int`. -pub inline extern int( i : int64 ) : int +pub inline fip extern int( i : int64 ) : int c "kk_integer_from_int64" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int64" // Convenient shorthand to `int64`, e.g. `1234.i64` -pub inline fun i64( i : int ) : int64 +pub inline fip fun i64( i : int ) : int64 i.int64 @@ -1238,13 +1243,13 @@ pub inline fun i64( i : int ) : int64 // ---------------------------------------------------------------------------- // clamp an `:int` to fit in an `:intptr_t`. -pub extern intptr_t( i : int) : intptr_t +pub fip extern intptr_t( i : int) : intptr_t c "kk_integer_clamp_intptr_t" cs "Primitive.IntToInt64" js "$std_core._int_clamp64" // Convert an `:intptr_t` to an `:int`. -pub inline extern int( i : intptr_t ) : int +pub inline fip extern int( i : intptr_t ) : int c "kk_integer_from_intptr_t" cs inline "(new BigInteger(#1))" js "$std_core._int_from_int64" @@ -1278,36 +1283,36 @@ extern xparse-int( s : string, hex : bool ) : maybe // todo: move to std/num/float64 // ---------------------------------------------------------------------------- -pub inline extern (==) : (float64,float64) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } -pub inline extern (!=) : (float64,float64) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } -pub inline extern (<=) : (float64,float64) -> bool { inline "(#1 <= #2)" } -pub inline extern (>=) : (float64,float64) -> bool { inline "(#1 >= #2)" } -pub inline extern (<) : (float64,float64) -> bool { inline "(#1 < #2)" } -pub inline extern (>) : (float64,float64) -> bool { inline "(#1 > #2)" } -pub inline extern (+) : (float64,float64) -> float64 { inline "(#1 + #2)" } -pub inline extern (-) : (float64,float64) -> float64 { inline "(#1 - #2)" } -pub inline extern (*) : (float64,float64) -> float64 { inline "(#1 * #2)" } -pub inline extern (/) : (float64,float64) -> float64 { inline "(#1 / #2)" } -pub inline extern (%) : (float64,float64) -> float64 { c inline "fmod(#1,#2)"; inline "(#1 % #2)" } +pub inline fip extern (==) : (float64,float64) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } +pub inline fip extern (!=) : (float64,float64) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } +pub inline fip extern (<=) : (float64,float64) -> bool { inline "(#1 <= #2)" } +pub inline fip extern (>=) : (float64,float64) -> bool { inline "(#1 >= #2)" } +pub inline fip extern (<) : (float64,float64) -> bool { inline "(#1 < #2)" } +pub inline fip extern (>) : (float64,float64) -> bool { inline "(#1 > #2)" } +pub inline fip extern (+) : (float64,float64) -> float64 { inline "(#1 + #2)" } +pub inline fip extern (-) : (float64,float64) -> float64 { inline "(#1 - #2)" } +pub inline fip extern (*) : (float64,float64) -> float64 { inline "(#1 * #2)" } +pub inline fip extern (/) : (float64,float64) -> float64 { inline "(#1 / #2)" } +pub inline fip extern (%) : (float64,float64) -> float64 { c inline "fmod(#1,#2)"; inline "(#1 % #2)" } // Is the value negative? -pub fun is-neg( d : float64 ) : bool +pub fip fun is-neg( d : float64 ) : bool d < 0.0 // Is the value positive? -pub fun is-pos( d : float64 ) : bool +pub fip fun is-pos( d : float64 ) : bool d > 0.0 // Is the value zero? -pub fun is-zero( d : float64 ) : bool +pub fip fun is-zero( d : float64 ) : bool d == 0.0 -pub fun sign( d : float64 ) : order +pub fip fun sign( d : float64 ) : order if d < 0.0 then Lt elif d > 0.0 then Gt else Eq // Negate a `:float64`. -pub inline extern (~)( f : float64 ) : float64 +pub inline fip extern (~)( f : float64 ) : float64 inline "(-#1)" // inline so `~0.0` becomes negative zero // convert a `:float64` to an `:int` using `round` to round to its nearest integer. @@ -1319,23 +1324,23 @@ pub inline extern int( f : float64 ) : int js "$std_core._int_double" // Returns the value `f` raised to the power `p` . -pub inline extern (^)( f : float64, p : float64) : float64 +pub inline fip extern (^)( f : float64, p : float64) : float64 c inline "pow(#1,#2)" cs "Math.Pow" js "Math.pow" // Return the absolute value of a `:float64` `f` -pub inline extern abs( f : float64 ) : float64 +pub inline fip extern abs( f : float64 ) : float64 c inline "kk_double_abs(#1)" cs "Math.Abs" js "Math.abs" // Returns the smallest of two floats -pub fun min( x : float64, y : float64 ) : float64 +pub fip fun min( x : float64, y : float64 ) : float64 if x <= y then x else y // Returns the largest of two floats -pub fun max( x : float64, y : float64 ) : float64 +pub fip fun max( x : float64, y : float64 ) : float64 if x >= y then x else y // Returns the smallest element of a list of floats (or `0` for the empty list) @@ -1361,10 +1366,10 @@ pub fun maximum( xs : list ) : float64 // returned by functions that find sub strings or patterns in // in strings. Use `string:(slice : sslice) -> string` to // create a fresh substring from a slice. -abstract struct sslice( str : string, start : ssize_t, len : ssize_t ) +abstract value struct sslice( str : string, start : int, len : int ) // Internal export for the regex module -pub fun ".new-sslice"( str :string, start: ssize_t, len : ssize_t ) +pub fun ".new-sslice"( str :string, start: int, len : int ) Sslice(str,start,len) // Convert a character to a string @@ -1435,8 +1440,8 @@ pub fun (||)( x : string, y : string ) : string if x.is-empty then y else x // Length returns the length in the platform specific encoding (and should not be exported) -inline extern length( s : string ) : ssize_t - c inline "kk_string_len(#1,kk_context())" +inline extern length( s : string ) : int + c inline "kk_string_len_int(#1,kk_context())" cs inline "#1.Length" js inline "#1.length" @@ -1475,21 +1480,21 @@ pub fun last(s : string, n : int = 1) : sslice // O(1). The entire string as a slice pub fun slice( s : string ) : sslice - Sslice(s,0.ssize_t,s.length) + Sslice(s,0,s.length) // An empty slice -val empty = Sslice("",0.ssize_t,0.ssize_t) +val empty = Sslice("",0,0) // Is a slice empty? pub fun is-empty( slice : sslice ) : bool !slice.len.is-pos // An invalid slice -val invalid = Sslice("",(-1).ssize_t,0.ssize_t) +val invalid = Sslice("",-1,0) // Is a slice invalid? pub fun is-valid( slice : sslice ) : bool - slice.start >= 0.ssize_t + slice.start >= 0 // Is a slice not empty? pub fun is-notempty( slice : sslice ) : bool @@ -1541,7 +1546,7 @@ pub extern extend( slice : sslice, ^count : int ) : sslice // start of `slice` argument. pub fun before(slice : sslice) : sslice val Sslice(s,start,_len) = slice - Sslice(s,0.ssize_t,start) + Sslice(s,0,start) // O(1). Return the string slice from the end of `slice` argument // to the end of the string. @@ -1591,7 +1596,7 @@ inline extern xindex-of(s : string, sub : string ) : ssize_t // the position just following the substring `sub`. pub fun find( s : string, sub : string ) : maybe val i = s.xindex-of(sub) - if i.is-zero then Nothing else Just(Sslice(s,i.decr,sub.length)) + if i.is-zero then Nothing else Just(Sslice(s,i.decr.int,sub.length)) // Does string `s` contain the string `sub` ? inline extern xlast-index-of(s : string, sub : string ) : ssize_t @@ -1602,7 +1607,7 @@ inline extern xlast-index-of(s : string, sub : string ) : ssize_t // Return the last index of substring `sub` in `s` if it occurs. pub fun find-last( s : string, sub : string ) : maybe val i = s.xlast-index-of(sub) - if i.is-zero then Nothing else Just(Sslice(s,i.decr,sub.length)) + if i.is-zero then Nothing else Just(Sslice(s,i.decr.int,sub.length)) inline extern xstarts-with: (s : string, pre : string ) -> bool c "kk_string_starts_with" @@ -1625,7 +1630,7 @@ extern xends-with: (s : string, post : string ) -> bool // If so, returns a slice of `s` from the start up to the `post` string at the end. pub fun ends-with( s : string, post : string ) : maybe if (xends-with(s,post)) - then Just(Sslice(s,0.ssize_t,s.length - post.length)) + then Just(Sslice(s,0,s.length - post.length)) else Nothing // Does string `s` contain the string `sub` ? @@ -1664,15 +1669,15 @@ pub fun trim-right( s : string, sub : string ) : string Just(slice) -> trim-right(unsafe-decreasing(slice.string),sub) Nothing -> s -// Repeat a string `n` times -pub fun repeat( s : string, ^n : int ) : string - repeatz(s,n.ssize_t) - extern repeatz( s : string, n : ssize_t ) : string c "kk_string_repeat" cs "Primitive.Repeat" js "_string_repeat" +// Repeat a string `n` times +pub fun repeat( s : string, ^n : int ) : string + repeatz(s,n.ssize_t) + // Convert a `:maybe` string to a string using the empty sting for `Nothing` pub fun string( ms : maybe ) : string match ms @@ -1778,19 +1783,19 @@ pub fun capitalize( s : string ) : string // Right-align a string to width `width` using `fill` (default is a space) to fill from the left. pub fun pad-left( s : string, ^width : int, fill : char = ' ') : string - val w = width.ssize_t + val w = width val n = s.length if w <= n then s - else fill.string.repeatz( w - n ) ++ s + else fill.string.repeat( w - n ) ++ s // Left-align a string to width `width` using `fill` (default is a space) to fill on the right. pub fun pad-right( s : string, ^width : int, fill : char = ' ') : string - val w = width.ssize_t + val w = width val n = s.length if w <= n then s - else s ++ fill.string.repeatz(w - n) + else s ++ fill.string.repeat(w - n) // Trim whitespace on the left and right side of a string pub fun trim( s : string ) : string @@ -1815,7 +1820,7 @@ pub inline extern trim-right( s : string ) : string // Return the element at position `index` in vector `v` without bounds check! inline extern unsafe-idx( ^v : vector, index : ssize_t ) : total a - c inline "kk_vector_at_borrow(#1,#2)" + c "kk_vector_at_borrow" cs inline "(#1)[#2]" js inline "(#1)[#2]" @@ -1845,7 +1850,7 @@ pub fun length( ^v : vector ) : int v.lengthz.int inline extern lengthz( ^v : vector ) : ssize_t - c inline "kk_vector_len_borrow(#1)" + c "kk_vector_len_borrow" cs inline "((#1).Length)" js inline "((#1).length)" @@ -1920,7 +1925,7 @@ pub extern unvlist( xs : list ) : vector // Delayed (or _lazy_) values are computed (with effect `:e`) only the first time // `force` is called and cached afterwards. -abstract type delayed +abstract value type delayed con Delay( dref : ref e a,a>> ) // Create a new `:delayed` value. @@ -2224,7 +2229,7 @@ pub fun ".default-exn"(action) show(exn).println // The exception data type -pub struct exception( message :string, info :exception-info ) +pub value struct exception( message :string, info :exception-info ) // Exception information pub open type exception-info @@ -2262,7 +2267,7 @@ pub fun catch( action : () -> a, hndl: exception -> e a) : e a try(action,hndl) // An `:error` type represents a first-class exception result. -pub type error +pub value type error Error( exception : exception ) Ok( result : a ) @@ -2324,20 +2329,20 @@ pub type null // Unsafe: transform any type to a `null` type; used internally by the compiler. pub extern ".null-any"(x : a) : null - c inline "((#1).box == kk_box_null.box ? kk_datatype_from_ptr(NULL) : kk_datatype_unbox(#1))" + c inline "(kk_box_is_null(#1) ? kk_datatype_null() : kk_datatype_unbox(#1))" cs inline "#1" js inline "(#1==null ? null : #1)" // undefined -> null // Transform a `:maybe` type to a `:null` type (using `null` for `Nothing`). pub extern null(x : maybe) : null - c inline "(kk_std_core_types__is_Nothing(#1) ? kk_datatype_from_ptr(NULL) : kk_datatype_unbox((#1)._cons.Just.value) /* kk_datatype_unbox(kk_datatype_unjust(#1,kk_context())) */ )" + c inline "(kk_std_core_types__is_Nothing(#1,kk_context()) ? kk_datatype_null() : kk_datatype_unbox((#1)._cons.Just.value) /* kk_datatype_unbox(kk_datatype_unjust(#1,kk_context())) */ )" cs inline "(#1.tag_ == __std_core._maybe_Tag.Nothing ? default(##1) : #1.@value)" js inline "(#1==null ? null : #1.value)" // Transform a `:null` type to a `:maybe` type. Note that it is not // always the case that `id(x) == maybe(null(x))` (e.g. when `x = Just(Nothing)`). pub extern maybe( n : null ) : maybe - c inline "(kk_datatype_as_ptr(#1) == NULL ? kk_std_core_types__new_Nothing(kk_context()) : kk_std_core_types__new_Just(kk_datatype_box(#1),kk_context()))" + c inline "(kk_datatype_is_null(#1) ? kk_std_core_types__new_Nothing(kk_context()) : kk_std_core_types__new_Just(kk_datatype_box(#1),kk_context()))" cs inline "(EqualityComparer<##1>.Default.Equals(#1,default(##1)) ? __std_core._maybe<##1>.Nothing_ : new __std_core._maybe<##1>(#1))" js inline "(#1==null ? $std_core_types.Nothing : $std_core_types.Just(#1))" @@ -2499,6 +2504,6 @@ pub alias value = a // Internal: used for value effects // TODO: revisit value effects codegen pub extern phantom() : a - c inline "kk_box_null" + c inline "kk_box_null()" inline "undefined" diff --git a/lib/std/core/core-inline.c b/lib/std/core/core-inline.c index 2cb830b26..3a5f690bc 100644 --- a/lib/std/core/core-inline.c +++ b/lib/std/core/core-inline.c @@ -10,7 +10,7 @@ kk_std_core__list kk_vector_to_list(kk_vector_t v, kk_std_core__list tail, kk_context_t* ctx) { // todo: avoid boxed_dup if v is unique kk_ssize_t n; - kk_box_t* p = kk_vector_buf_borrow(v, &n); + kk_box_t* p = kk_vector_buf_borrow(v, &n, ctx); if (n <= 0) { kk_vector_drop(v,ctx); return tail; @@ -19,14 +19,14 @@ kk_std_core__list kk_vector_to_list(kk_vector_t v, kk_std_core__list tail, kk_co struct kk_std_core_Cons* cons = NULL; kk_std_core__list list = kk_std_core__new_Nil(ctx); for( kk_ssize_t i = 0; i < n; i++ ) { - kk_std_core__list hd = kk_std_core__new_Cons(kk_reuse_null,kk_box_dup(p[i]), nil, ctx); + kk_std_core__list hd = kk_std_core__new_Cons(kk_reuse_null,0,kk_box_dup(p[i],ctx), nil, ctx); if (cons==NULL) { list = hd; } else { cons->tail = hd; } - cons = kk_std_core__as_Cons(hd); + cons = kk_std_core__as_Cons(hd,ctx); } if (cons == NULL) { list = tail; } else { cons->tail = tail; } @@ -39,8 +39,8 @@ kk_vector_t kk_list_to_vector(kk_std_core__list xs, kk_context_t* ctx) { // find the length kk_ssize_t len = 0; kk_std_core__list ys = xs; - while (kk_std_core__is_Cons(ys)) { - struct kk_std_core_Cons* cons = kk_std_core__as_Cons(ys); + while (kk_std_core__is_Cons(ys,ctx)) { + struct kk_std_core_Cons* cons = kk_std_core__as_Cons(ys,ctx); len++; ys = cons->tail; } @@ -49,9 +49,9 @@ kk_vector_t kk_list_to_vector(kk_std_core__list xs, kk_context_t* ctx) { kk_vector_t v = kk_vector_alloc_uninit(len, &p, ctx); ys = xs; for( kk_ssize_t i = 0; i < len; i++) { - struct kk_std_core_Cons* cons = kk_std_core__as_Cons(ys); + struct kk_std_core_Cons* cons = kk_std_core__as_Cons(ys,ctx); ys = cons->tail; - p[i] = kk_box_dup(cons->head); + p[i] = kk_box_dup(cons->head,ctx); } kk_std_core__list_drop(xs,ctx); // todo: drop while visiting? return v; @@ -61,21 +61,21 @@ kk_vector_t kk_vector_init( kk_ssize_t n, kk_function_t init, kk_context_t* ctx) kk_box_t* p; kk_vector_t v = kk_vector_alloc_uninit(n, &p, ctx); for(kk_ssize_t i = 0; i < n; i++) { - kk_function_dup(init); - p[i] = kk_function_call(kk_box_t,(kk_function_t,kk_ssize_t,kk_context_t*),init,(init,i,ctx)); + kk_function_dup(init,ctx); + p[i] = kk_function_call(kk_box_t,(kk_function_t,kk_ssize_t,kk_context_t*),init,(init,i,ctx),ctx); } kk_function_drop(init,ctx); return v; } kk_box_t kk_main_console( kk_function_t action, kk_context_t* ctx ) { - return kk_function_call(kk_box_t,(kk_function_t,kk_unit_t,kk_context_t*),action,(action,kk_Unit,ctx)); + return kk_function_call(kk_box_t,(kk_function_t,kk_unit_t,kk_context_t*),action,(action,kk_Unit,ctx),ctx); } kk_std_core__list kk_string_to_list(kk_string_t s, kk_context_t* ctx) { kk_ssize_t len; - const uint8_t* p = kk_string_buf_borrow(s,&len); + const uint8_t* p = kk_string_buf_borrow(s,&len,ctx); const uint8_t* const end = p + len; kk_std_core__list nil = kk_std_core__new_Nil(ctx); kk_std_core__list list = nil; @@ -84,14 +84,14 @@ kk_std_core__list kk_string_to_list(kk_string_t s, kk_context_t* ctx) { while( p < end ) { kk_char_t c = kk_utf8_read(p,&count); p += count; - kk_std_core__list cons = kk_std_core__new_Cons(kk_reuse_null,kk_char_box(c,ctx), nil, ctx); + kk_std_core__list cons = kk_std_core__new_Cons(kk_reuse_null,0,kk_char_box(c,ctx), nil, ctx); if (tl!=NULL) { tl->tail = cons; } else { list = cons; } - tl = kk_std_core__as_Cons(cons); + tl = kk_std_core__as_Cons(cons,ctx); } kk_string_drop(s,ctx); return list; @@ -102,47 +102,49 @@ kk_string_t kk_string_from_list(kk_std_core__list cs, kk_context_t* ctx) { // find total UTF8 length kk_ssize_t len = 0; kk_std_core__list xs = cs; - while (kk_std_core__is_Cons(xs)) { - struct kk_std_core_Cons* cons = kk_std_core__as_Cons(xs); - len += kk_utf8_len(kk_char_unbox(cons->head,ctx)); + while (kk_std_core__is_Cons(xs,ctx)) { + struct kk_std_core_Cons* cons = kk_std_core__as_Cons(xs,ctx); + len += kk_utf8_len(kk_char_unbox(cons->head,KK_BORROWED,ctx)); xs = cons->tail; } // allocate and copy the characters uint8_t* p; kk_string_t s = kk_unsafe_string_alloc_buf(len,&p,ctx); // must be initialized xs = cs; - while (kk_std_core__is_Cons(xs)) { - struct kk_std_core_Cons* cons = kk_std_core__as_Cons(xs); + while (kk_std_core__is_Cons(xs,ctx)) { + struct kk_std_core_Cons* cons = kk_std_core__as_Cons(xs,ctx); kk_ssize_t count; - kk_utf8_write( kk_char_unbox(cons->head,ctx), p, &count ); + kk_utf8_write( kk_char_unbox(cons->head,KK_BORROWED,ctx), p, &count ); p += count; xs = cons->tail; } - kk_assert_internal(*p == 0 && (p - kk_string_buf_borrow(s,NULL)) == len); + kk_assert_internal(*p == 0 && (p - kk_string_buf_borrow(s,NULL,ctx)) == len); kk_std_core__list_drop(cs,ctx); // todo: drop while visiting? return s; } -static inline void kk_sslice_start_end_borrowx( kk_std_core__sslice sslice, const uint8_t** start, const uint8_t** end, const uint8_t** sstart, const uint8_t** send) { - kk_ssize_t slen; - const uint8_t* s = kk_string_buf_borrow(sslice.str,&slen); - *start = s + sslice.start; - *end = s + sslice.start + sslice.len; +static inline void kk_sslice_start_end_borrowx( kk_std_core__sslice sslice, const uint8_t** start, const uint8_t** end, const uint8_t** sstart, const uint8_t** send, kk_context_t* ctx) { + kk_ssize_t strlen; + const uint8_t* s = kk_string_buf_borrow(sslice.str,&strlen,ctx); + kk_ssize_t slstart = kk_integer_clamp_ssize_t_borrow(sslice.start,ctx); + kk_ssize_t sllen = kk_integer_clamp_ssize_t_borrow(sslice.len,ctx); + *start = s + slstart; + *end = s + slstart + sllen; if (sstart != NULL) *sstart = s; - if (send != NULL) *send = s + slen; + if (send != NULL) *send = s + strlen; kk_assert_internal(*start >= s && *start <= *end); - kk_assert_internal(*end >= *start && *end <= s + slen); + kk_assert_internal(*end >= *start && *end <= s + strlen); } -static inline void kk_sslice_start_end_borrow( kk_std_core__sslice sslice, const uint8_t** start, const uint8_t** end) { - kk_sslice_start_end_borrowx(sslice,start,end,NULL,NULL); +static inline void kk_sslice_start_end_borrow( kk_std_core__sslice sslice, const uint8_t** start, const uint8_t** end, kk_context_t* ctx) { + kk_sslice_start_end_borrowx(sslice,start,end,NULL,NULL,ctx); } kk_integer_t kk_slice_count( kk_std_core__sslice sslice, kk_context_t* ctx ) { // TODO: optimize this by extending kk_string_count const uint8_t* start; const uint8_t* end; - kk_sslice_start_end_borrow(sslice, &start, &end); + kk_sslice_start_end_borrow(sslice, &start, &end, ctx); kk_ssize_t count = 0; while( start < end && *start != 0 ) { const uint8_t* next = kk_utf8_next(start); @@ -156,15 +158,16 @@ kk_integer_t kk_slice_count( kk_std_core__sslice sslice, kk_context_t* ctx ) { kk_string_t kk_slice_to_string( kk_std_core__sslice sslice, kk_context_t* ctx ) { const uint8_t* start; const uint8_t* end; - kk_sslice_start_end_borrow(sslice, &start, &end); + kk_sslice_start_end_borrow(sslice, &start, &end, ctx); // is it the full string? - if (sslice.start == 0 && sslice.len == kk_string_len_borrow(sslice.str)) { + if (kk_integer_is_zero_borrow(sslice.start) && + kk_integer_eq_borrow(sslice.len,kk_integer_from_ssize_t(kk_string_len_borrow(sslice.str,ctx),ctx),ctx)) { // TODO: drop sslice and dup sslice.str? return sslice.str; } else { // if not, we copy len bytes - kk_string_t s = kk_string_alloc_dupn_valid_utf8(sslice.len, start, ctx); + kk_string_t s = kk_string_alloc_dupn_valid_utf8(kk_integer_clamp_ssize_t_borrow(sslice.len,ctx), start, ctx); kk_std_core__sslice_drop(sslice,ctx); return s; } @@ -172,56 +175,68 @@ kk_string_t kk_slice_to_string( kk_std_core__sslice sslice, kk_context_t* ctx ) kk_std_core__sslice kk_slice_first( kk_string_t str, kk_context_t* ctx ) { kk_ssize_t slen; - const uint8_t* s = kk_string_buf_borrow(str,&slen); + const uint8_t* s = kk_string_buf_borrow(str,&slen,ctx); const uint8_t* next = (slen > 0 ? kk_utf8_next(s) : s); - return kk_std_core__new_Sslice(str, 0, (next - s), ctx); + return kk_std_core__new_Sslice(str, kk_integer_zero, kk_integer_from_ptrdiff_t(next - s,ctx), ctx); } kk_std_core__sslice kk_slice_last( kk_string_t str, kk_context_t* ctx ) { kk_ssize_t slen; - const uint8_t* s = kk_string_buf_borrow(str,&slen); + const uint8_t* s = kk_string_buf_borrow(str,&slen,ctx); const uint8_t* end = s + slen; const uint8_t* prev = (s==end ? s : kk_utf8_prev(end)); - return kk_std_core__new_Sslice(str, (prev - s), (end - prev), ctx); + return kk_std_core__new_Sslice(str, kk_integer_from_ptrdiff_t(prev - s,ctx), kk_integer_from_ptrdiff_t(end - prev,ctx), ctx); } kk_std_core__sslice kk_slice_between( struct kk_std_core_Sslice slice1, struct kk_std_core_Sslice slice2, kk_context_t* ctx ) { - const uint8_t* s1 = kk_string_buf_borrow( slice1.str, NULL ); - const uint8_t* s2 = kk_string_buf_borrow( slice2.str, NULL ); + const uint8_t* s1 = kk_string_buf_borrow( slice1.str, NULL, ctx ); + const uint8_t* s2 = kk_string_buf_borrow( slice2.str, NULL, ctx ); if (s1 != s2) { kk_info_message("between: not equal slices: %p vs. %p\n", s1, s2); - return kk_std_core__new_Sslice(kk_string_empty(), 0, -1, ctx); // invalid slice + return kk_std_core__new_Sslice(kk_string_empty(), kk_integer_zero, kk_integer_min_one, ctx); // invalid slice + } + + kk_integer_t start; + kk_integer_t len; + if (kk_integer_lte_borrow(slice1.start,slice2.start,ctx)) { + start = kk_integer_dup(slice1.start,ctx); + len = kk_integer_sub(kk_integer_dup(slice2.start,ctx),kk_integer_dup(slice1.start,ctx),ctx); } - kk_ssize_t start = (slice1.start <= slice2.start ? slice1.start : slice2.start); - kk_ssize_t len = (slice1.start <= slice2.start ? slice2.start - slice1.start : slice1.start - slice2.start); + else { + start = kk_integer_dup(slice2.start,ctx); + len = kk_integer_sub(kk_integer_dup(slice1.start,ctx),kk_integer_dup(slice2.start,ctx),ctx); + } return kk_std_core__new_Sslice(slice1.str, start, len, ctx); } kk_std_core_types__maybe kk_slice_next( struct kk_std_core_Sslice slice, kk_context_t* ctx ) { - if (slice.len <= 0) { + if (!kk_integer_is_pos_borrow(slice.len,ctx)) { kk_std_core__sslice_drop(slice,ctx); return kk_std_core_types__new_Nothing(ctx); } const uint8_t* start; const uint8_t* end; - kk_sslice_start_end_borrow(slice, &start, &end); + kk_sslice_start_end_borrow(slice, &start, &end, ctx); kk_ssize_t clen; const kk_char_t c = kk_utf8_read(start,&clen); - kk_assert_internal(clen > 0 && clen <= slice.len); - if (clen > slice.len) clen = slice.len; + kk_assert_internal(clen > 0 && clen <= kk_integer_clamp_ssize_t_borrow(slice.len,ctx)); + kk_integer_t iclen = kk_integer_min(kk_integer_from_ssize_t(clen,ctx),kk_integer_dup(slice.len,ctx),ctx); // TODO: specialize type to avoid boxing - kk_std_core__sslice snext = kk_std_core__new_Sslice(slice.str, slice.start + clen, slice.len - clen, ctx); + // note: don't drop slice as we take over all fields + kk_integer_t istart = kk_integer_add(slice.start,kk_integer_dup(iclen,ctx),ctx); + kk_integer_t ilen = kk_integer_sub(slice.len,iclen,ctx); + kk_std_core__sslice snext = kk_std_core__new_Sslice(slice.str, istart, ilen, ctx); kk_std_core_types__tuple2_ res = kk_std_core_types__new_dash__lp__comma__rp_( kk_char_box(c,ctx), kk_std_core__sslice_box(snext,ctx), ctx); return kk_std_core_types__new_Just( kk_std_core_types__tuple2__box(res,ctx), ctx ); } /* Borrow count */ struct kk_std_core_Sslice kk_slice_extend_borrow( struct kk_std_core_Sslice slice, kk_integer_t count, kk_context_t* ctx ) { - kk_ssize_t cnt = kk_integer_clamp_borrow(count,ctx); - if (cnt==0 || (slice.len <= 0 && cnt<0)) return slice; + kk_ssize_t cnt = kk_integer_clamp_ssize_t_borrow(count,ctx); + if (cnt==0 || (!kk_integer_is_pos_borrow(slice.len,ctx) && cnt<0)) return slice; const uint8_t* s0; const uint8_t* s1; - kk_sslice_start_end_borrow(slice,&s0,&s1); + kk_sslice_start_end_borrow(slice,&s0,&s1,ctx); const uint8_t* t = s1; if (cnt >= 0) { do { @@ -230,26 +245,27 @@ struct kk_std_core_Sslice kk_slice_extend_borrow( struct kk_std_core_Sslice slic } while (cnt > 0 && *t != 0); } else { // cnt < 0 - const uint8_t* sstart = s0 - slice.start; + const uint8_t* sstart = s0 - kk_integer_clamp_ssize_t_borrow(slice.start,ctx); do { t = kk_utf8_prev(t); cnt++; } while (cnt < 0 && t > sstart); } if (t == s1) return slice; // length is unchanged - return kk_std_core__new_Sslice(slice.str, slice.start, (t < s0 ? 0 : (t - s0)), ctx); + kk_integer_drop(slice.len,ctx); + return kk_std_core__new_Sslice(slice.str, slice.start, kk_integer_from_ptrdiff_t(t < s0 ? 0 : (t - s0),ctx), ctx); } /* Borrow count */ struct kk_std_core_Sslice kk_slice_advance_borrow( struct kk_std_core_Sslice slice, kk_integer_t count, kk_context_t* ctx ) { - const kk_ssize_t cnt0 = kk_integer_clamp_borrow(count,ctx); + const kk_ssize_t cnt0 = kk_integer_clamp_ssize_t_borrow(count,ctx); kk_ssize_t cnt = cnt0; - if (cnt==0 || (slice.start == 0 && cnt<0)) return slice; + if (cnt==0 || (kk_integer_is_zero_borrow(slice.start) && cnt<0)) return slice; const uint8_t* sstart; const uint8_t* s0; const uint8_t* s1; const uint8_t* send; - kk_sslice_start_end_borrowx(slice,&s0,&s1,&sstart,&send); + kk_sslice_start_end_borrowx(slice,&s0,&s1,&sstart,&send,ctx); // advance the start const uint8_t* t0 = s0; if (cnt >= 0) { @@ -282,20 +298,23 @@ struct kk_std_core_Sslice kk_slice_advance_borrow( struct kk_std_core_Sslice sli } // t1 points to the new end kk_assert_internal(t1 >= t0); - return kk_std_core__new_Sslice(slice.str, (t0 - sstart), (t1 - t0), ctx); + kk_integer_drop(slice.start,ctx); + kk_integer_drop(slice.len,ctx); + return kk_std_core__new_Sslice(slice.str, kk_integer_from_ptrdiff_t(t0 - sstart,ctx), + kk_integer_from_ptrdiff_t(t1 - t0,ctx), ctx); } /* Borrow iupto */ struct kk_std_core_Sslice kk_slice_common_prefix_borrow( kk_string_t str1, kk_string_t str2, kk_integer_t iupto, kk_context_t* ctx ) { - const uint8_t* s1 = kk_string_buf_borrow(str1,NULL); - const uint8_t* s2 = kk_string_buf_borrow(str2,NULL); + const uint8_t* s1 = kk_string_buf_borrow(str1,NULL,ctx); + const uint8_t* s2 = kk_string_buf_borrow(str2,NULL,ctx); kk_ssize_t upto = kk_integer_clamp_ssize_t_borrow(iupto,ctx); kk_ssize_t count; for(count = 0; count < upto && *s1 != 0 && *s2 != 0; count++, s1++, s2++ ) { if (*s1 != *s2) break; } kk_string_drop(str2,ctx); - return kk_std_core__new_Sslice(str1, 0, count, ctx); + return kk_std_core__new_Sslice(str1, kk_integer_zero, kk_integer_from_ssize_t(count,ctx), ctx); } @@ -324,12 +343,12 @@ kk_std_core__error kk_error_from_errno( int err, kk_context_t* ctx ) { // Old style msg = kk_string_alloc_from_qutf8( strerror(err), ctx ); #endif - return kk_std_core__new_Error( kk_std_core__new_Exception( msg, kk_std_core__new_ExnSystem(kk_reuse_null, kk_integer_from_int(err,ctx), ctx), ctx), ctx ); + return kk_std_core__new_Error( kk_std_core__new_Exception( msg, kk_std_core__new_ExnSystem(kk_reuse_null, 0, kk_integer_from_int(err,ctx), ctx), ctx), ctx ); } kk_unit_t kk_assert_fail( kk_string_t msg, kk_context_t* ctx ) { - kk_fatal_error(EINVAL, "assertion failed: %s\n", kk_string_cbuf_borrow(msg,NULL)); + kk_fatal_error(EINVAL, "assertion failed: %s\n", kk_string_cbuf_borrow(msg,NULL,ctx)); kk_string_drop(msg,ctx); return kk_Unit; } \ No newline at end of file diff --git a/lib/std/core/core-inline.h b/lib/std/core/core-inline.h index d91ca36b6..9969ce8a1 100644 --- a/lib/std/core/core-inline.h +++ b/lib/std/core/core-inline.h @@ -21,9 +21,9 @@ static inline kk_std_core_types__order kk_int_as_order(int i,kk_context_t* ctx) static inline kk_std_core_types__maybe kk_integer_xparse( kk_string_t s, bool hex, kk_context_t* ctx ) { kk_integer_t i; - bool ok = (hex ? kk_integer_hex_parse(kk_string_cbuf_borrow(s,NULL),&i,ctx) : kk_integer_parse(kk_string_cbuf_borrow(s,NULL),&i,ctx) ); + bool ok = (hex ? kk_integer_hex_parse(kk_string_cbuf_borrow(s,NULL,ctx),&i,ctx) : kk_integer_parse(kk_string_cbuf_borrow(s,NULL,ctx),&i,ctx) ); kk_string_drop(s,ctx); - return (ok ? kk_std_core_types__new_Just(kk_integer_box(i),ctx) : kk_std_core_types__new_Nothing(ctx)); + return (ok ? kk_std_core_types__new_Just(kk_integer_box(i,ctx),ctx) : kk_std_core_types__new_Nothing(ctx)); } struct kk_std_core_Sslice; @@ -45,8 +45,9 @@ static inline kk_integer_t kk_string_cmp_int(kk_string_t s1, kk_string_t s2, kk_ kk_string_t kk_string_join(kk_vector_t v, kk_context_t* ctx); kk_string_t kk_string_join_with(kk_vector_t v, kk_string_t sep, kk_context_t* ctx); kk_string_t kk_string_replace_all(kk_string_t str, kk_string_t pattern, kk_string_t repl, kk_context_t* ctx); + static inline kk_integer_t kk_string_count_pattern(kk_string_t str, kk_string_t pattern, kk_context_t* ctx) { - kk_integer_t count = kk_integer_from_ssize_t( kk_string_count_pattern_borrow(str,pattern), ctx ); + kk_integer_t count = kk_integer_from_ssize_t( kk_string_count_pattern_borrow(str,pattern,ctx), ctx ); kk_string_drop(str,ctx); kk_string_drop(pattern,ctx); return count; @@ -65,7 +66,7 @@ kk_std_core_types__maybe kk_slice_next( struct kk_std_core_Sslice slice, kk_cont static inline kk_unit_t kk_vector_unsafe_assign( kk_vector_t v, kk_ssize_t i, kk_box_t x, kk_context_t* ctx ) { kk_ssize_t len; - kk_box_t* p = kk_vector_buf_borrow(v,&len); + kk_box_t* p = kk_vector_buf_borrow(v,&len,ctx); kk_assert(i < len); p[i] = x; kk_vector_drop(v,ctx); // TODO: use borrowing @@ -76,7 +77,7 @@ kk_vector_t kk_vector_init( kk_ssize_t n, kk_function_t init, kk_context_t* ctx) static inline kk_box_t kk_vector_at_int_borrow( kk_vector_t v, kk_integer_t n, kk_context_t* ctx) { // TODO: check bounds - kk_box_t b = kk_vector_at_borrow(v,kk_integer_clamp_ssize_t_borrow(n,ctx)); + kk_box_t b = kk_vector_at_borrow(v,kk_integer_clamp_ssize_t_borrow(n,ctx),ctx); return b; } @@ -87,7 +88,7 @@ static inline double kk_double_abs(double d) { static inline kk_std_core_types__tuple2_ kk_integer_div_mod_tuple(kk_integer_t x, kk_integer_t y, kk_context_t* ctx) { kk_integer_t mod; kk_integer_t div = kk_integer_div_mod(x,y,&mod,ctx); - return kk_std_core_types__new_dash__lp__comma__rp_(kk_integer_box(div),kk_integer_box(mod),ctx); + return kk_std_core_types__new_dash__lp__comma__rp_(kk_integer_box(div,ctx),kk_integer_box(mod,ctx),ctx); } kk_box_t kk_main_console( kk_function_t action, kk_context_t* ctx ); diff --git a/lib/std/core/core-integer-inline.js b/lib/std/core/core-integer-inline.js index de01a6814..35532fc69 100644 --- a/lib/std/core/core-integer-inline.js +++ b/lib/std/core/core-integer-inline.js @@ -74,6 +74,46 @@ export function _int32_rotr(x,y) { return ((x >>> shift) | (x << (32 - shift))); } +export function _int32_clz(x) { + return Math.clz32(x); +} + +export function _int32_ctz(x) { + var i = (x|0); + if (i === 0) return 32; + i = (i & ((~i) + 1)); // keep only least significant bit + return ((31 - Math.clz32(i))|0); +} + +export function _int32_ffs(x) { // find first set bit: bit-index + 1, or 0 for zero + return (x == 0 ? 0 : 1 + _int32_ctz(x)); +} + +export function _int32_clrsb(x) { + var i = (x|0); + i = i ^ (i >> 31); + return (i===0 ? 31 : _int32_clz(i) - 1); +} + +export function _int32_parity(x) { + var i = x|0; + i ^= (i >>> 16); + i ^= (i >>> 8); + i ^= (i >>> 4); + i &= 0x0F; + return (((0x6996 >> x) & 1) === 0); // 0x6996 = 0b0110100110010110 == "mini" 16 bit lookup table with a bit set if the value has non-even parity +} + +export function _int32_popcount(x) { + var i = (x|0); + i = i - ((i >> 1) & 0x55555555); + i = (i & 0x33333333) + ((i >> 2) & 0x33333333); + i = (i + (i >> 4)) & 0x0F0F0F0F; + i = i + (i >> 8); + i = i + (i >> 16); + return (i & 0x3F); +} + const _int65 = 0x10000000000000000n; export function _int64_shr(x,y) { @@ -110,6 +150,68 @@ export function _int64_rotr(x,y) { return _int64_rotl(x, 64n - y); } +function _int64_hi(x) { + return (Number( (x>>32n) & 0xFFFFFFFFn ) | 0); +} + +function _int64_lo(x) { + return (Number( x & 0xFFFFFFFFn ) | 0); +} + +export function _int64_ctz(x) { + const lo = _int64_lo(x); + if (lo === 0) { + const hi = _int64_hi(x); + return BigInt(32 + _int32_ctz(hi)); + } + else { + return BigInt(_int32_ctz(lo)); + } +} + +export function _int64_clz(x) { + const hi = _int64_hi(x); + if (hi === 0) { + const lo = _int64_lo(x); + return BigInt(32 + _int32_clz(lo)); + } + else { + return BigInt(_int32_clz(hi)); + } +} + +export function _int64_ffs(x) { // find first set bit: bit-index + 1, or 0 for zero + return (x === 0n ? 0n : 1n + _int64_ctz(x)); +} + +export function _int64_clrsb(x) { + const hi = _int64_hi(x); + const lo = _int64_lo(x); + if (hi === 0) { + return (lo < 0 ? 31 : 32 + _int32_clrsb(lo)); + } + else if (hi === -1) { + return (lo >= 0 ? 31 : 32 + _int32_clrsb(lo)); + } + else { + return BigInt(_int32_clrsb(hi)); + } +} + +export function _int64_parity(x) { + const hi = _int64_hi(x); + const lo = _int64_lo(x); + const i = (lo ^ hi); + return _int32_parity(i); +} + +export function _int64_popcount(x) { + const hi = _int64_hi(x); + const lo = _int64_lo(x); + return BigInt(_int32_popcount(hi) + _int32_popcount(lo)); +} + + export function _int64_from_uint32(x) { return (x >= 0 ? BigInt(x) : 0x100000000n + BigInt(x)) } @@ -118,16 +220,16 @@ export function _int64_from_int32(x) { return BigInt(x); } -const _max_uint32 = 0xFFFFFFFFn; -const _max_int32 = 0x7FFFFFFFn; -const _min_int32 = -0x80000000n; +const _max_uint32n = 0xFFFFFFFFn; +const _max_int32n = 0x7FFFFFFFn; +const _min_int32n = -0x80000000n; export function _int64_clamp_int32(x) { - return (x > _max_int32n ? _max_int32n : (x < _min_int32n ? _min_int32n : Number(x))); + return Number( x > _max_int32n ? _max_int32n : (x < _min_int32n ? _min_int32n : x) ); } export function _int64_clamp_uint32(x) { - return (x > _max_uint32n ? -1 : (x < 0 ? 0 : (x <= _max_int32n ? Number(x) : Number(x) - 0x100000000))); + return Number(x > _max_uint32n ? -1 : (x < 0 ? 0 : (x <= _max_int32n ? x : x - 0x100000000n))); } @@ -595,6 +697,7 @@ export function _int_clamp32(x) { } export function _int_from_int32(x) { + // console.log("int_from_int32: " + x + ": " + typeof x) return x; } diff --git a/lib/std/core/hnd-inline.c b/lib/std/core/hnd-inline.c index 6f90cf693..33b46cd27 100644 --- a/lib/std/core/hnd-inline.c +++ b/lib/std/core/hnd-inline.c @@ -30,34 +30,35 @@ static kk_std_core_hnd__ev* kk_evv_vector_buf(kk_evv_vector_t vec, kk_ssize_t* l return &vec->vec[0]; } -static kk_std_core_hnd__ev* kk_evv_as_vec(kk_evv_t evv, kk_ssize_t* len, kk_std_core_hnd__ev* single) { - if (kk_evv_is_vector(evv)) { - kk_evv_vector_t vec = kk_evv_as_vector(evv); +static kk_std_core_hnd__ev* kk_evv_as_vec(kk_evv_t evv, kk_ssize_t* len, kk_std_core_hnd__ev* single, kk_context_t* ctx) { + if (kk_evv_is_vector(evv,ctx)) { + kk_evv_vector_t vec = kk_evv_as_vector(evv,ctx); *len = kk_block_scan_fsize(&vec->_block) - 1; return &vec->vec[0]; } else { // single evidence - *single = kk_evv_as_ev(evv); + *single = kk_evv_as_ev(evv,ctx); *len = 1; return single; } } kk_std_core_hnd__ev kk_ev_none(kk_context_t* ctx) { - static kk_std_core_hnd__ev ev_none_singleton; - if (ev_none_singleton==NULL) { + static kk_std_core_hnd__ev ev_none_singleton = { kk_datatype_null_init }; + if (kk_datatype_is_null(ev_none_singleton)) { ev_none_singleton = kk_std_core_hnd__new_Ev( kk_reuse_null, + 0, // cpath kk_std_core_hnd__new_Htag(kk_string_empty(),ctx), // tag "" kk_std_core_hnd__new_Marker(0,ctx), // marker 0 - kk_box_null, // no handler + kk_box_null(), // no handler -1, // bot kk_evv_empty(ctx), ctx ); } - return kk_std_core_hnd__ev_dup(ev_none_singleton); + return kk_std_core_hnd__ev_dup(ev_none_singleton,ctx); } @@ -65,10 +66,10 @@ kk_ssize_t kk_evv_index( struct kk_std_core_hnd_Htag htag, kk_context_t* ctx ) { // todo: drop htag? kk_ssize_t len; kk_std_core_hnd__ev single; - kk_std_core_hnd__ev* vec = kk_evv_as_vec(ctx->evv,&len,&single); + kk_std_core_hnd__ev* vec = kk_evv_as_vec(ctx->evv,&len,&single,ctx); for(kk_ssize_t i = 0; i < len; i++) { - struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(vec[i]); - if (kk_string_cmp_borrow(htag.tagname,ev->htag.tagname) <= 0) return i; // break on insertion point + struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(vec[i],ctx); + if (kk_string_cmp_borrow(htag.tagname,ev->htag.tagname,ctx) <= 0) return i; // break on insertion point } //string_t evvs = kk_evv_show(dup_datatype_as(kk_evv_t,ctx->evv),ctx); //fatal_error(EFAULT,"cannot find tag '%s' in: %s", string_cbuf_borrow(htag.htag), string_cbuf_borrow(evvs)); @@ -89,18 +90,18 @@ static inline int32_t kk_cfc_lub(int32_t cfc1, int32_t cfc2) { else return cfc2; } -static inline struct kk_std_core_hnd_Ev* kk_evv_as_Ev( kk_evv_t evv ) { - return kk_std_core_hnd__as_Ev(kk_evv_as_ev(evv)); +static inline struct kk_std_core_hnd_Ev* kk_evv_as_Ev( kk_evv_t evv, kk_context_t* ctx ) { + return kk_std_core_hnd__as_Ev(kk_evv_as_ev(evv,ctx),ctx); } static int32_t kk_evv_cfc_of_borrow(kk_evv_t evv, kk_context_t* ctx) { - if (kk_evv_is_vector(evv)) { - kk_evv_vector_t vec = kk_evv_as_vector(evv); + if (kk_evv_is_vector(evv,ctx)) { + kk_evv_vector_t vec = kk_evv_as_vector(evv,ctx); return kk_integer_clamp32_borrow(vec->cfc,ctx); } else { - struct kk_std_core_hnd_Ev* ev = kk_evv_as_Ev(evv); + struct kk_std_core_hnd_Ev* ev = kk_evv_as_Ev(evv,ctx); return ev->cfc; } } @@ -110,24 +111,24 @@ int32_t kk_evv_cfc(kk_context_t* ctx) { } static void kk_evv_update_cfc_borrow(kk_evv_t evv, int32_t cfc, kk_context_t* ctx) { - kk_assert_internal(!kk_evv_is_empty(evv)); // should never happen (as named handlers are always in some context) - if (kk_evv_is_vector(evv)) { - kk_evv_vector_t vec = kk_evv_as_vector(evv); + kk_assert_internal(!kk_evv_is_empty(evv,ctx)); // should never happen (as named handlers are always in some context) + if (kk_evv_is_vector(evv,ctx)) { + kk_evv_vector_t vec = kk_evv_as_vector(evv,ctx); vec->cfc = kk_integer_from_int32(kk_cfc_lub(kk_integer_clamp32_borrow(vec->cfc,ctx),cfc), ctx); } else { - struct kk_std_core_hnd_Ev* ev = kk_evv_as_Ev(evv); + struct kk_std_core_hnd_Ev* ev = kk_evv_as_Ev(evv,ctx); ev->cfc = kk_cfc_lub(ev->cfc,cfc); } } kk_evv_t kk_evv_insert(kk_evv_t evvd, kk_std_core_hnd__ev evd, kk_context_t* ctx) { - struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(evd); + struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(evd,ctx); // update ev with parent evidence vector (either at init, or due to non-scoped resumptions) int32_t marker = ev->marker.m; if (marker==0) { kk_std_core_hnd__ev_drop(evd,ctx); return evvd; } // ev-none kk_evv_drop(ev->hevv,ctx); - ev->hevv = kk_evv_dup(evvd); + ev->hevv = kk_evv_dup(evvd,ctx); if (marker<0) { // negative marker is used for named evidence; this means this evidence should not be inserted into the evidence vector kk_evv_update_cfc_borrow(evvd,ev->cfc,ctx); // update cfc in-place for named evidence kk_std_core_hnd__ev_drop(evd,ctx); @@ -136,11 +137,11 @@ kk_evv_t kk_evv_insert(kk_evv_t evvd, kk_std_core_hnd__ev evd, kk_context_t* ctx // for regular handler evidence, insert ev kk_ssize_t n; kk_std_core_hnd__ev single; - kk_std_core_hnd__ev* const evv1 = kk_evv_as_vec(evvd, &n, &single); + kk_std_core_hnd__ev* const evv1 = kk_evv_as_vec(evvd, &n, &single, ctx); if (n == 0) { // use ev directly as the evidence vector kk_evv_drop(evvd, ctx); - return &evd->_block; + return kk_ev_as_evv(evd,ctx); } else { // create evidence vector @@ -150,23 +151,23 @@ kk_evv_t kk_evv_insert(kk_evv_t evvd, kk_std_core_hnd__ev evd, kk_context_t* ctx kk_std_core_hnd__ev* const evv2 = kk_evv_vector_buf(vec2, NULL); kk_ssize_t i; for (i = 0; i < n; i++) { - struct kk_std_core_hnd_Ev* ev1 = kk_std_core_hnd__as_Ev(evv1[i]); - if (kk_string_cmp_borrow(ev->htag.tagname, ev1->htag.tagname) <= 0) break; - evv2[i] = kk_std_core_hnd__ev_dup(&ev1->_base); + struct kk_std_core_hnd_Ev* ev1 = kk_std_core_hnd__as_Ev(evv1[i],ctx); + if (kk_string_cmp_borrow(ev->htag.tagname, ev1->htag.tagname,ctx) <= 0) break; + evv2[i] = kk_std_core_hnd__ev_dup(evv1[i],ctx); } evv2[i] = evd; for (; i < n; i++) { - evv2[i+1] = kk_std_core_hnd__ev_dup(evv1[i]); + evv2[i+1] = kk_std_core_hnd__ev_dup(evv1[i],ctx); } kk_evv_drop(evvd, ctx); // assigned to evidence already - return &vec2->_block; + return kk_datatype_from_base(vec2,ctx); } } kk_evv_t kk_evv_delete(kk_evv_t evvd, kk_ssize_t index, bool behind, kk_context_t* ctx) { kk_ssize_t n; kk_std_core_hnd__ev single; - const kk_std_core_hnd__ev* evv1 = kk_evv_as_vec(evvd, &n, &single); + const kk_std_core_hnd__ev* evv1 = kk_evv_as_vec(evvd, &n, &single, ctx); if (n <= 1) { kk_evv_drop(evvd,ctx); return kk_evv_total(ctx); @@ -179,55 +180,55 @@ kk_evv_t kk_evv_delete(kk_evv_t evvd, kk_ssize_t index, bool behind, kk_context_ kk_std_core_hnd__ev* const evv2 = kk_evv_vector_buf(vec2,NULL); kk_ssize_t i; for(i = 0; i < index; i++) { - evv2[i] = kk_std_core_hnd__ev_dup(evv1[i]); + evv2[i] = kk_std_core_hnd__ev_dup(evv1[i],ctx); } for(; i < n-1; i++) { - evv2[i] = kk_std_core_hnd__ev_dup(evv1[i+1]); + evv2[i] = kk_std_core_hnd__ev_dup(evv1[i+1],ctx); } - struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(evv1[index]); + struct kk_std_core_hnd_Ev* ev = kk_std_core_hnd__as_Ev(evv1[index],ctx); if (ev->cfc >= cfc1) { - int32_t cfc = kk_std_core_hnd__as_Ev(evv2[0])->cfc; + int32_t cfc = kk_std_core_hnd__as_Ev(evv2[0],ctx)->cfc; for(i = 1; i < n-1; i++) { - cfc = kk_cfc_lub(cfc,kk_std_core_hnd__as_Ev(evv2[i])->cfc); + cfc = kk_cfc_lub(cfc,kk_std_core_hnd__as_Ev(evv2[i],ctx)->cfc); } vec2->cfc = kk_integer_from_int32(cfc,ctx); } kk_evv_drop(evvd,ctx); - return &vec2->_block; + return kk_datatype_from_base(vec2,ctx); } kk_evv_t kk_evv_create(kk_evv_t evv1, kk_vector_t indices, kk_context_t* ctx) { kk_ssize_t len; - kk_box_t* elems = kk_vector_buf_borrow(indices,&len); // borrows + kk_box_t* elems = kk_vector_buf_borrow(indices,&len,ctx); // borrows kk_evv_vector_t evv2 = kk_evv_vector_alloc(len,kk_evv_cfc_of_borrow(evv1,ctx),ctx); kk_std_core_hnd__ev* buf2 = kk_evv_vector_buf(evv2,NULL); - kk_assert_internal(kk_evv_is_vector(evv1)); + kk_assert_internal(kk_evv_is_vector(evv1,ctx)); kk_ssize_t len1; kk_std_core_hnd__ev single; - kk_std_core_hnd__ev* buf1 = kk_evv_as_vec(evv1,&len1,&single); + kk_std_core_hnd__ev* buf1 = kk_evv_as_vec(evv1,&len1,&single,ctx); for(kk_ssize_t i = 0; i < len; i++) { - kk_ssize_t idx = kk_ssize_unbox(elems[i],ctx); + kk_ssize_t idx = kk_ssize_unbox(elems[i],KK_BORROWED,ctx); kk_assert_internal(idx < len1); - buf2[i] = kk_std_core_hnd__ev_dup( buf1[idx] ); + buf2[i] = kk_std_core_hnd__ev_dup( buf1[idx], ctx ); } kk_vector_drop(indices,ctx); kk_evv_drop(evv1,ctx); - return &evv2->_block; + return kk_datatype_from_base(evv2,ctx); } kk_evv_t kk_evv_swap_create( kk_vector_t indices, kk_context_t* ctx ) { kk_ssize_t len; - kk_box_t* vec = kk_vector_buf_borrow(indices,&len); + kk_box_t* vec = kk_vector_buf_borrow(indices,&len,ctx); if (len==0) { kk_vector_drop(indices,ctx); return kk_evv_swap_create0(ctx); } if (len==1) { - kk_ssize_t i = kk_ssize_unbox(vec[0],ctx); + kk_ssize_t i = kk_ssize_unbox(vec[0],KK_BORROWED,ctx); kk_vector_drop(indices,ctx); return kk_evv_swap_create1(i,ctx); } - return kk_evv_swap( kk_evv_create(kk_evv_dup(ctx->evv),indices,ctx), ctx ); + return kk_evv_swap( kk_evv_create(kk_evv_dup(ctx->evv,ctx),indices,ctx), ctx ); } @@ -248,19 +249,19 @@ struct kcompose_fun_s { // kleisli composition of continuations static kk_box_t kcompose( kk_function_t fself, kk_box_t x, kk_context_t* ctx) { - struct kcompose_fun_s* self = kk_function_as(struct kcompose_fun_s*,fself); + struct kcompose_fun_s* self = kk_function_as(struct kcompose_fun_s*,fself,ctx); kk_intx_t count = kk_intf_unbox(self->count); kk_function_t* conts = &self->conts[0]; // call each continuation in order for(kk_intx_t i = 0; i < count; i++) { // todo: take uniqueness of fself into account to avoid dup_function - kk_function_t f = kk_function_dup(conts[i]); - x = kk_function_call(kk_box_t, (kk_function_t, kk_box_t, kk_context_t*), f, (f, x, ctx)); + kk_function_t f = kk_function_dup(conts[i],ctx); + x = kk_function_call(kk_box_t, (kk_function_t, kk_box_t, kk_context_t*), f, (f, x, ctx), ctx); if (kk_yielding(ctx)) { // if yielding, `yield_next` all continuations that still need to be done while(++i < count) { // todo: if fself is unique, we could copy without dup? - kk_yield_extend(kk_function_dup(conts[i]),ctx); + kk_yield_extend(kk_function_dup(conts[i],ctx),ctx); } kk_function_drop(fself,ctx); kk_box_drop(x,ctx); // still drop even though we yield as it may release a boxed value type? @@ -271,16 +272,16 @@ static kk_box_t kcompose( kk_function_t fself, kk_box_t x, kk_context_t* ctx) { return x; } -static kk_function_t new_kcompose( kk_function_t* conts, kk_ssize_t count, kk_context_t* ctx ) { +static kk_function_t new_kcompose( kk_function_t* conts, kk_intf_t count, kk_context_t* ctx ) { if (count==0) return kk_function_id(ctx); if (count==1) return conts[0]; struct kcompose_fun_s* f = kk_block_as(struct kcompose_fun_s*, kk_block_alloc(kk_ssizeof(struct kcompose_fun_s) - kk_ssizeof(kk_function_t) + (count*kk_ssizeof(kk_function_t)), 2 + count /* scan size */, KK_TAG_FUNCTION, ctx)); - f->_base.fun = kk_cfun_ptr_box(&kcompose,ctx); + f->_base.fun = kk_kkfun_ptr_box(&kcompose,ctx); f->count = kk_intf_box(count); kk_memcpy(f->conts, conts, count * kk_ssizeof(kk_function_t)); - return (&f->_base); + return kk_datatype_from_base(&f->_base,ctx); } /*----------------------------------------------------------------------- @@ -314,19 +315,19 @@ struct cont_apply_fun_s { }; static kk_box_t cont_apply( kk_function_t fself, kk_box_t x, kk_context_t* ctx ) { - struct cont_apply_fun_s* self = kk_function_as(struct cont_apply_fun_s*, fself); + struct cont_apply_fun_s* self = kk_function_as(struct cont_apply_fun_s*, fself, ctx); kk_function_t f = self->f; kk_function_t cont = self->cont; - kk_drop_match(self,{kk_function_dup(f);kk_function_dup(cont);},{},ctx); - return kk_function_call( kk_box_t, (kk_function_t, kk_function_t, kk_box_t, kk_context_t* ctx), f, (f, cont, x, ctx)); + kk_drop_match(self,{kk_function_dup(f,ctx);kk_function_dup(cont,ctx);},{},ctx); + return kk_function_call( kk_box_t, (kk_function_t, kk_function_t, kk_box_t, kk_context_t* ctx), f, (f, cont, x, ctx), ctx); } static kk_function_t kk_new_cont_apply( kk_function_t f, kk_function_t cont, kk_context_t* ctx ) { struct cont_apply_fun_s* self = kk_function_alloc_as(struct cont_apply_fun_s, 3, ctx); - self->_base.fun = kk_cfun_ptr_box(&cont_apply,ctx); + self->_base.fun = kk_kkfun_ptr_box(&cont_apply,ctx); self->f = f; self->cont = cont; - return (&self->_base); + return kk_datatype_from_base(&self->_base,ctx); } // Unlike `yield_extend`, `yield_cont` gets access to the current continuation. This is used in `yield_prompt`. @@ -351,7 +352,7 @@ kk_function_t kk_yield_to( struct kk_std_core_hnd_Marker m, kk_function_t clause yield->marker = m.m; yield->clause = clause; yield->conts_count = 0; - return kk_basetype_unbox_as(kk_function_t,kk_box_any(ctx)); + return kk_datatype_unbox(kk_box_any(ctx)); } kk_box_t kk_yield_final( struct kk_std_core_hnd_Marker m, kk_function_t clause, kk_context_t* ctx ) { @@ -371,7 +372,7 @@ static kk_box_t _fatal_resume_final(kk_function_t self, kk_context_t* ctx) { } static kk_function_t fun_fatal_resume_final(kk_context_t* ctx) { kk_define_static_function(f,_fatal_resume_final,ctx); - return kk_function_dup(f); + return kk_function_dup(f,ctx); } @@ -395,7 +396,7 @@ struct kk_std_core_hnd_yld_s kk_yield_prompt( struct kk_std_core_hnd_Marker m, k } kk_unit_t kk_evv_guard(kk_evv_t evv, kk_context_t* ctx) { - bool eq = (ctx->evv == evv); + bool eq = kk_datatype_eq(ctx->evv,evv); kk_evv_drop(evv,ctx); if (!eq) { // todo: improve error message with diagnostics @@ -408,7 +409,7 @@ typedef struct yield_info_s { struct kk_std_core_hnd__yield_info_s _base; kk_function_t clause; kk_function_t conts[KK_YIELD_CONT_MAX]; - kk_ssize_t conts_count; + kk_intf_t conts_count; int32_t marker; int8_t yielding; }* yield_info_t; @@ -429,18 +430,18 @@ kk_std_core_hnd__yield_info kk_yield_capture(kk_context_t* ctx) { yld->yielding = ctx->yielding; ctx->yielding = 0; ctx->yield.conts_count = 0; - return kk_datatype_from_base(&yld->_base); + return kk_datatype_from_base(&yld->_base,ctx); } kk_box_t kk_yield_reyield( kk_std_core_hnd__yield_info yldinfo, kk_context_t* ctx) { kk_assert_internal(!kk_yielding(ctx)); - yield_info_t yld = kk_datatype_as_assert(yield_info_t, yldinfo, (kk_tag_t)1); - ctx->yield.clause = kk_function_dup(yld->clause); + yield_info_t yld = kk_datatype_as_assert(yield_info_t, yldinfo, (kk_tag_t)1, ctx); + ctx->yield.clause = kk_function_dup(yld->clause,ctx); ctx->yield.marker = yld->marker; ctx->yield.conts_count = yld->conts_count; ctx->yielding = yld->yielding; for(kk_ssize_t i = 0; i < yld->conts_count; i++) { - ctx->yield.conts[i] = kk_function_dup(yld->conts[i]); + ctx->yield.conts[i] = kk_function_dup(yld->conts[i],ctx); } kk_constructor_drop(yld,ctx); return kk_box_any(ctx); diff --git a/lib/std/core/hnd-inline.h b/lib/std/core/hnd-inline.h index e8168e3bd..b3883adb4 100644 --- a/lib/std/core/hnd-inline.h +++ b/lib/std/core/hnd-inline.h @@ -1,3 +1,9 @@ + + + + + + /*--------------------------------------------------------------------------- Copyright 2020-2021, Microsoft Research, Daan Leijen. @@ -5,64 +11,72 @@ terms of the Apache License, Version 2.0. A copy of the License can be found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -struct kk_std_core_hnd__ev_s; -static inline struct kk_std_core_hnd__ev_s* kk_std_core_hnd__ev_dup(struct kk_std_core_hnd__ev_s* _x); +typedef kk_datatype_ptr_t kk_std_core_hnd__ev_t; +static inline kk_std_core_hnd__ev_t kk_std_core_hnd__ev_dup(kk_std_core_hnd__ev_t _x, kk_context_t* ctx); typedef struct kk_evv_vector_s { - struct kk_block_s _block; - kk_integer_t cfc; // control flow context (0-3) as a small int - struct kk_std_core_hnd__ev_s* vec[1]; + struct kk_block_s _block; + kk_integer_t cfc; // control flow context (0-3) as a small int + kk_std_core_hnd__ev_t vec[1]; } *kk_evv_vector_t; -typedef kk_ptr_t kk_evv_t; // either a kk_evv_vector_t, or a single evidence +typedef kk_datatype_ptr_t kk_evv_t; // either a kk_evv_vector_t, or a single evidence -static inline kk_evv_t kk_evv_dup(kk_evv_t evv) { - return kk_block_dup(evv); +static inline kk_evv_t kk_evv_dup(kk_evv_t evv, kk_context_t* ctx) { + return kk_datatype_ptr_dup(evv,ctx); } static inline void kk_evv_drop(kk_evv_t evv, kk_context_t* ctx) { - kk_block_drop(evv,ctx); + kk_datatype_ptr_drop(evv,ctx); } static inline kk_evv_t kk_evv_empty(kk_context_t* ctx) { - kk_unused(ctx); - return kk_evv_dup(kk_evv_empty_singleton); + return kk_evv_empty_singleton(ctx); } -static inline bool kk_evv_is_empty(kk_evv_t evv) { - return (evv == kk_evv_empty_singleton); +static inline bool kk_evv_is_empty(kk_evv_t evv, kk_context_t* ctx) { // todo: optimize + kk_evv_t empty = kk_evv_empty(ctx); + bool eq = kk_datatype_eq(evv,empty); + kk_datatype_ptr_drop(empty,ctx); + return eq; } -static inline bool kk_evv_is_vector(kk_evv_t evv) { - return kk_block_has_tag(evv,KK_TAG_EVV_VECTOR); +static inline bool kk_evv_is_vector(kk_evv_t evv, kk_context_t* ctx) { + return kk_datatype_ptr_has_tag(evv,KK_TAG_EVV_VECTOR,ctx); } -static inline struct kk_std_core_hnd__ev_s* kk_evv_as_ev( kk_evv_t evv ) { - kk_assert_internal(!kk_evv_is_vector(evv)); - return (struct kk_std_core_hnd__ev_s*)evv; +static inline kk_std_core_hnd__ev_t kk_evv_as_ev( kk_evv_t evv, kk_context_t* ctx ) { + kk_unused_internal(ctx); + kk_assert_internal(!kk_evv_is_vector(evv,ctx)); + return evv; +} + +static inline kk_evv_t kk_ev_as_evv( kk_std_core_hnd__ev_t ev, kk_context_t* ctx ) { + kk_unused(ctx); + return ev; } -static inline kk_evv_vector_t kk_evv_as_vector( kk_evv_t evv ) { - kk_assert_internal(kk_evv_is_vector(evv)); - return (kk_evv_vector_t)evv; +static inline kk_evv_vector_t kk_evv_as_vector( kk_evv_t evv, kk_context_t* ctx ) { + kk_assert_internal(kk_evv_is_vector(evv,ctx)); + return kk_datatype_as_assert(kk_evv_vector_t,evv,KK_TAG_EVV_VECTOR,ctx); } -static inline struct kk_std_core_hnd__ev_s* kk_evv_at( kk_ssize_t i, kk_context_t* ctx ) { +static inline kk_std_core_hnd__ev_t kk_evv_at( kk_ssize_t i, kk_context_t* ctx ) { kk_evv_t evv = ctx->evv; - if (!kk_evv_is_vector(evv)) { // evv is a single evidence + if (!kk_evv_is_vector(evv,ctx)) { // evv is a single evidence kk_assert_internal(i==0); - return kk_evv_as_ev(kk_evv_dup(evv)); + return kk_evv_as_ev(kk_evv_dup(evv,ctx),ctx); } else { // evv as a vector - kk_assert_internal(i >= 0 && i < (kk_block_scan_fsize(evv) - 1)); - kk_evv_vector_t vec = kk_evv_as_vector(evv); - return kk_std_core_hnd__ev_dup(vec->vec[i]); + kk_assert_internal(i >= 0 && i < (kk_block_scan_fsize(kk_datatype_as_ptr(evv,ctx)) - 1)); + kk_evv_vector_t vec = kk_evv_as_vector(evv,ctx); + return kk_std_core_hnd__ev_dup(vec->vec[i],ctx); } } static inline kk_evv_t kk_evv_get(kk_context_t* ctx) { - return kk_evv_dup(ctx->evv); + return kk_evv_dup(ctx->evv,ctx); } static inline kk_unit_t kk_evv_set(kk_evv_t evv, kk_context_t* ctx) { @@ -72,13 +86,13 @@ static inline kk_unit_t kk_evv_set(kk_evv_t evv, kk_context_t* ctx) { } static inline kk_evv_t kk_evv_swap(kk_evv_t evv, kk_context_t* ctx) { - kk_ptr_t evv0 = ctx->evv; + kk_evv_t evv0 = ctx->evv; ctx->evv = evv; return evv0; } static inline bool kk_evv_eq(kk_evv_t evv1, kk_evv_t evv2, kk_context_t* ctx) { // TODO:make borrowing - bool eq = (evv1 == evv2); + bool eq = kk_datatype_eq(evv1,evv2); kk_evv_drop(evv1,ctx); kk_evv_drop(evv2,ctx); return eq; @@ -94,13 +108,13 @@ static inline kk_evv_t kk_evv_swap_create0(kk_context_t* ctx) { static inline kk_evv_t kk_evv_swap_create1(kk_ssize_t i, kk_context_t* ctx) { kk_evv_t evv0 = ctx->evv; - if (kk_evv_is_vector(evv0)) { - ctx->evv = (kk_block_t*)kk_evv_at(i, ctx); // cast as ev struct is not defined yet + if (kk_evv_is_vector(evv0,ctx)) { + ctx->evv = kk_evv_at(i, ctx); // cast as ev struct is not defined yet return evv0; } else { kk_assert_internal(i==0); - return kk_evv_dup(evv0); // already a single evidence + return kk_evv_dup(evv0,ctx); // already a single evidence } } @@ -109,12 +123,12 @@ struct kk_std_core_hnd_Marker; struct kk_std_core_hnd_yld_s; -struct kk_std_core_hnd__ev_s* kk_ev_none(kk_context_t* cxt); -struct kk_std_core_hnd__ev_s* kk_evv_lookup( struct kk_std_core_hnd_Htag htag, kk_context_t* ctx ); +kk_std_core_hnd__ev_t kk_ev_none(kk_context_t* cxt); +kk_std_core_hnd__ev_t kk_evv_lookup( struct kk_std_core_hnd_Htag htag, kk_context_t* ctx ); int32_t kk_evv_cfc(kk_context_t* ctx); kk_ssize_t kk_evv_index( struct kk_std_core_hnd_Htag htag, kk_context_t* ctx ); kk_evv_t kk_evv_create(kk_evv_t evv, kk_vector_t indices, kk_context_t* ctx); -kk_evv_t kk_evv_insert(kk_evv_t evv, struct kk_std_core_hnd__ev_s* ev, kk_context_t* ctx); +kk_evv_t kk_evv_insert(kk_evv_t evv, kk_std_core_hnd__ev_t ev, kk_context_t* ctx); kk_evv_t kk_evv_delete(kk_evv_t evv, kk_ssize_t index, bool behind, kk_context_t* ctx); kk_string_t kk_evv_show(kk_evv_t evv, kk_context_t* ctx); kk_unit_t kk_evv_guard(kk_evv_t evv, kk_context_t* ctx); @@ -131,6 +145,6 @@ kk_box_t kk_yield_reyield(kk_datatype_t yld, kk_context_t* ctx); static inline kk_evv_t kk_evv_swap_delete(kk_ssize_t i, bool behind, kk_context_t* ctx) { kk_evv_t evv0 = ctx->evv; - ctx->evv = kk_evv_delete(kk_evv_dup(evv0), i, behind, ctx); + ctx->evv = kk_evv_delete(kk_evv_dup(evv0,ctx), i, behind, ctx); return evv0; } diff --git a/lib/std/core/hnd.kk b/lib/std/core/hnd.kk index 1402c221a..9966f0412 100644 --- a/lib/std/core/hnd.kk +++ b/lib/std/core/hnd.kk @@ -39,10 +39,10 @@ extern import // ------------------------------------------- // Each handler in the context has a unique marker. -struct marker( m : int32) +value struct marker( m : int32) // The tag of a handler identifies the type at runtime (e.g. `"exn/core/std"`). -abstract type htagV> +abstract value type htagV> Htag(tagname:string) pub fun ".new-htag"( tag : string ) @@ -252,7 +252,7 @@ value type resume-result Shallow( result: b ) Finalize( result : r ) -type yld +value type yld Pure YieldingFinal Yielding @@ -427,7 +427,7 @@ fun initially-prompt( init : (int) -> e (), res : a ) : e a // Resume context // ------------------------------------------- -abstract struct resume-context( k : resume-result -> e r ) +abstract value struct resume-context( k : resume-result -> e r ) pub fun resume( r : resume-context, x : b ) : e r (r.k)(Deep(x)) @@ -444,7 +444,7 @@ pub fun finalize( r : resume-context, x : r ) : e r // Clauses // ------------------------------------------- -abstract type clause1 +abstract value type clause1 Clause1( clause: (marker, ev, a) -> e b ) inline extern cast-ev0( f : (marker,ev) -> e1 b) : e ((marker,ev) -> e b) @@ -528,7 +528,7 @@ pub fun clause-never1( op : a -> e r ) : clause1 // 0 arguments; reuse 1 argument Clauses //---------------------------------------------------------------- -abstract type clause0 +abstract value type clause0 Clause0( clause: (marker, ev) -> e b ) @@ -574,7 +574,7 @@ pub fun clause-never0( op : () -> e r ) : clause0 // 2 arguments //---------------------------------------------------------------- -abstract type clause2 +abstract value type clause2 Clause2( clause: (marker, ev, a1, a2) -> e b ) fun under2( ev : ev, op : (a1,a2) -> e b, x1 : a1, x2 : a2 ) : e b diff --git a/lib/std/core/types-cctx-inline.h b/lib/std/core/types-cctx-inline.h new file mode 100644 index 000000000..69c353512 --- /dev/null +++ b/lib/std/core/types-cctx-inline.h @@ -0,0 +1,82 @@ + + + + + + +/*--------------------------------------------------------------------------- + Copyright 2020-2023, Microsoft Research, Daan Leijen. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the LICENSE file at the root of this distribution. +---------------------------------------------------------------------------*/ + +static inline kk_box_t kk_cctx_hole(void) { + return kk_intf_box(0); // for now, this must be a value; see `kklib/src/refcount.c:kk_cctx_copy_apply` +} + +static inline kk_std_core_types__cctx kk_cctx_empty(kk_context_t* ctx) { + return kk_std_core_types__new_Cctx( kk_cctx_hole(), NULL, ctx); +} + +static inline kk_std_core_types__cctx kk_cctx_create( kk_box_t res, kk_box_t* field, kk_context_t* ctx) { + return kk_std_core_types__new_Cctx( res, field, ctx); +} + + +static inline kk_box_t kk_cctx_apply_linear( kk_std_core_types__cctx acc, kk_box_t child ) { + #if 1 + if (kk_likely(acc.holeptr != NULL)) { + kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res,kk_get_context()))); + *(acc.holeptr) = child; + return acc.res; + } + else { + return child; + } + #else + // this form entices conditional moves (but seems slower in general) + if (acc.holeptr != NULL) { *acc.holeptr = child; } + return (acc.holeptr != NULL ? acc.res : child); + #endif +} + +static inline kk_box_t kk_cctx_apply_nonlinear( kk_std_core_types__cctx acc, kk_box_t child, kk_context_t* ctx ) { + // note: written like this for best codegen; be careful when rewriting. + if (acc.holeptr != NULL && kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))) { // no kk_likely seem slightly better + kk_assert_internal(kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))); + *(acc.holeptr) = child; // in-place update the hole with the child + return acc.res; + } + else if (kk_likely(acc.holeptr == NULL)) { + return child; + } + else { + kk_assert_internal(!kk_block_is_unique(kk_ptr_unbox(acc.res,ctx))); + return kk_cctx_copy_apply(acc.res,acc.holeptr,child,ctx); // copy the context path to the hole and compose with the child + } +} + +// apply a context to a child value +// is_linear is always a constant and set to `true` if the effect is guaranteed linear +static inline kk_box_t kk_cctx_apply( kk_std_core_types__cctx acc, kk_box_t child, bool is_linear, kk_context_t* ctx ) { + #if defined(KK_CCTX_NO_CONTEXT_PATH) + return kk_cctx_apply_linear(acc,child); // compiler generates the right code for the non-linear case + #else + if (is_linear) return kk_cctx_apply_linear(acc,child); + else return kk_cctx_apply_nonlinear(acc,child,ctx); + #endif +} + +// extend a context with a non-empty context +static inline kk_std_core_types__cctx kk_cctx_extend( kk_std_core_types__cctx acc, kk_box_t child, kk_box_t* field, bool is_linear, kk_context_t* ctx ) { + return kk_std_core_types__new_Cctx( kk_cctx_apply(acc,child,is_linear,ctx), field, ctx ); +} + +// compose a context +static inline kk_std_core_types__cctx kk_cctx_compose( kk_std_core_types__cctx acc1, kk_std_core_types__cctx acc2, bool is_linear, kk_context_t* ctx ) { + if (acc2.holeptr == NULL) return acc1; + return kk_cctx_extend(acc1,acc2.res,acc2.holeptr,is_linear,ctx); +} + diff --git a/lib/std/core/types-cctx-inline.js b/lib/std/core/types-cctx-inline.js new file mode 100644 index 000000000..8635715d0 --- /dev/null +++ b/lib/std/core/types-cctx-inline.js @@ -0,0 +1,43 @@ +/*--------------------------------------------------------------------------- + Copyright 2012-2023, Microsoft Research, Daan Leijen. + + This is free software; you can redistribute it and/or modify it under the + terms of the Apache License, Version 2.0. A copy of the License can be + found in the LICENSE file at the root of this distribution. +---------------------------------------------------------------------------*/ +export function _cctx_empty() { + return _Cctx(undefined,{obj:undefined,field_name:""}) +} + +export function _cctx_create(res,field_addr) { + return _Cctx(res,field_addr); +} + +export function _cctx_extend(acc,res,field_addr) { + if (acc.res===undefined) { + return _Cctx(res,field_addr); + } + else { + acc.holeptr.obj[acc.holeptr.field_name] = res; + return _Cctx(acc.res,field_addr); + } +} + +export function _cctx_compose(ctx1,ctx2) { + if (ctx2.res==undefined) { + return ctx1; + } + else { + return _cctx_extend(ctx1,ctx2.res,ctx2.field_addr); + } +} + +export function _cctx_apply(acc,res) { + if (acc.res===undefined) { + return res; + } + else { + acc.holeptr.obj[acc.holeptr.field_name] = res; + return acc.res; + } +} diff --git a/lib/std/core/types-ctail-inline.h b/lib/std/core/types-ctail-inline.h deleted file mode 100644 index f4c195e89..000000000 --- a/lib/std/core/types-ctail-inline.h +++ /dev/null @@ -1,30 +0,0 @@ - - - - - - -/*--------------------------------------------------------------------------- - Copyright 2020-2021, Microsoft Research, Daan Leijen. - - This is free software; you can redistribute it and/or modify it under the - terms of the Apache License, Version 2.0. A copy of the License can be - found in the LICENSE file at the root of this distribution. ----------------------------------------------------------------------------*/ - -static inline kk_box_t kk_ctail_hole(void) { - return kk_intf_box(0); -} - -static inline kk_std_core_types__ctail kk_ctail_nil(void) { - return kk_std_core_types__new_CTail( kk_ctail_hole(), NULL, NULL ); -} - -static inline kk_std_core_types__ctail kk_ctail_link( kk_std_core_types__ctail acc, kk_box_t res, kk_box_t* field ) { - return kk_std_core_types__new_CTail( (kk_likely(acc.hole != NULL) ? (*(acc.hole) = res, acc.res) : res ), field, NULL ); -} - -static inline kk_box_t kk_ctail_resolve( kk_std_core_types__ctail acc, kk_box_t res ) { - return (kk_likely(acc.hole != NULL) ? (*(acc.hole) = res, acc.res) : res ); -} - diff --git a/lib/std/core/types-ctail-inline.js b/lib/std/core/types-ctail-inline.js deleted file mode 100644 index ff19ac68f..000000000 --- a/lib/std/core/types-ctail-inline.js +++ /dev/null @@ -1,30 +0,0 @@ -/*--------------------------------------------------------------------------- - Copyright 2012-2021, Microsoft Research, Daan Leijen. - - This is free software; you can redistribute it and/or modify it under the - terms of the Apache License, Version 2.0. A copy of the License can be - found in the LICENSE file at the root of this distribution. ----------------------------------------------------------------------------*/ -export function _ctail_nil() { - return _CTail(undefined,{value:undefined,field:""}) -} - -export function _ctail_link(acc,res,field) { - if (acc.res===undefined) { - return _CTail(res,field); - } - else { - acc.hole.value[acc.hole.field] = res; - return _CTail(acc.res,field); - } -} - -export function _ctail_resolve(acc,res) { - if (acc.res===undefined) { - return res; - } - else { - acc.hole.value[acc.hole.field] = res; - return acc.res; - } -} diff --git a/lib/std/core/types.kk b/lib/std/core/types.kk index 2cf25a1a6..58205f1c5 100644 --- a/lib/std/core/types.kk +++ b/lib/std/core/types.kk @@ -9,15 +9,19 @@ /* Core types. This module is implicitly imported and all functions and types - are always available. + are always available. These types are required to be defined for the compiler to work correctly (i.e. types like `:int` or `:div`) */ module std/core/types +pub infixr 60 (++) +pub infixr 55 (++.) pub infixr 30 (&&) pub infixr 20 (||) +// build: 113 + // ---------------------------------------------------------------------------- // Core types // ---------------------------------------------------------------------------- @@ -76,8 +80,8 @@ pub value type intptr_t // Provides currently no operations and currently only used for storage and for interaction with external code. pub value type float32 -// An any type. Used for extern calls -pub reference type any +// An any type. Used for external calls +pub type any // Internal type used for in-place update of unique pattern matches pub type reuse @@ -143,10 +147,10 @@ pub type bool pub struct () // A pair of values `:a` and `:b`. -pub struct (,)(fst:a,snd:b) +pub value struct (,)(fst:a,snd:b) // A triple of values. -pub struct (,,)(fst:a,snd:b,thd:c) +pub value struct (,,)(fst:a,snd:b,thd:c) // A quadruple of values. pub struct (,,,)(fst:a,snd:b,thd:c,field4:d) @@ -156,12 +160,12 @@ pub struct (,,,,)(fst:a,snd:b,thd:c,field4:d,field5:e) // The `:maybe` type is used to represent either a value (`Just(x)`) or `Nothing`. // This type is often used to represent values that can be _null_. -pub type maybe +pub value type maybe con Nothing con Just( value : a ) // The choice type represents one of two possible types `:a` or `:b`. -pub type either +pub value type either con Left( left : a ) con Right( right : b ) @@ -175,42 +179,46 @@ pub type order pub value type box con Box( unbox : a ) + +/* // Explicitly heap allocate using the `Hbox` constructor. -pub reference type hbox +pub ref type hbox con Hbox( unhbox : a ) pub fun hbox( x : a ) : hbox Hbox(x) +*/ -pub noinline fun keep( x : a ) : a +// Prevent inlining an expression by passing it to `keep` (which is a non-inlineable identity function) +pub noinline fip fun keep( x : a ) : a x // ---------------------------------------------------------------------------- -// Standard functions +// Standard functions // ---------------------------------------------------------------------------- // The identity function returns its argument unchanged -pub fun id(x : a) : a +pub fip fun id(x : a) : a x // Logical conjuction -pub fun (&&)( x : bool, y : bool) : bool // inlined in the compiler for short-circuit evaluation +pub fip fun (&&)( x : bool, y : bool) : bool // inlined in the compiler for short-circuit evaluation if x then y else False // Logical disjunction -pub fun (||)( x : bool, y : bool) : bool // inlined in the compiler for short-circuit evaluation +pub fip fun (||)( x : bool, y : bool) : bool // inlined in the compiler for short-circuit evaluation if x then True else y // Logical negation -pub fun (!)( b : bool ) : bool +pub fip fun (!)( b : bool ) : bool if b then False else True // Logical negation -pub fun not( b : bool ) : bool +pub fip fun not( b : bool ) : bool if b then False else True // _Internal_: 32-bit zero, needed for markers in `std/core/hnd`. -pub inline extern zero32() : int32 +pub inline fip extern zero32() : int32 inline "0" // _Internal_: generated by type inference and later refined into one of the `open` variants in `std/core/hnd`. @@ -267,7 +275,7 @@ pub inline extern modify : forall ( ref : ref, f : forall local // If a heap effect is unobservable, the heap effect can be erased by using the `run` fun. // See also: _State in Haskell, by Simon Peyton Jones and John Launchbury_. pub extern run : forall ( action : forall () -> ,read,write | e> a ) -> e a - c inline "(kk_function_call(kk_box_t,(kk_function_t,kk_context_t*),#1,(#1,kk_context())))" + c inline "(kk_function_call(kk_box_t,(kk_function_t,kk_context_t*),#1,(#1,kk_context()),kk_context()))" cs inline "Primitive.Run<##2>(#1)" js inline "((#1)())" @@ -323,10 +331,10 @@ pub inline extern byref(loc : a) : a // ---------------------------------------------------------------------------- // _Unsafe_. Mark a function parameter as decreasing to suppress the non-termination effect (`:div`). -pub inline extern unsafe-decreasing( x : a ) : a +pub inline fip extern unsafe-decreasing( x : a ) : a inline "#1" -inline extern unsafe-total-cast : forall ( action : () -> e a ) -> (() -> a) +inline fip extern unsafe-total-cast : forall ( action : () -> e a ) -> (() -> a) inline "#1" // _Unsafe_. This function calls a function and pretends it did not have any effect at all. @@ -357,19 +365,65 @@ pub value type optional // ---------------------------------------------------------------------------- +// First-class constructor contexts. // These primitives are used by the compiler for // _tail recursion module cons_ (TRMC) optimization. // ---------------------------------------------------------------------------- -extern import - c header-end-file "types-ctail-inline.h" - js file "types-ctail-inline.js" +extern import + c header-end-file "types-cctx-inline.h" + js file "types-cctx-inline.js" -// _Internal_. Internal type for _tail recursion module cons_ (TRMC) optimization. +// _Internal_. Internal type for constructor contexts. // Holds the address to a field of type `:a` in a constructor. -pub value type cfield - -// _Internal_. Internal type for _tail recursion module cons_ (TRMC) optimization. -abstract value type ctail - ".CTail"( res : a, hole : cfield ) +pub value type field-addr + +// First-class constructor context (for _tail recursion module cons_ (TRMC) optimization). +abstract value type cctx + con ".Cctx"( res : a, holeptr : field-addr ) + +// First-class constructor context. +pub alias ctx = cctx + +// _Internal_. Create a hole for a context +pub inline fip extern ".cctx-hole-create"() : a + c inline "kk_intf_box(0)" + js inline "undefined" + +// _Internal_. Create an initial non-empty context. +pub inline fip extern ".cctx-create"( x : a, xhole : field-addr ) : cctx + c "kk_cctx_create" + js "_cctx_create" + +// _Internal_. Extend a constructor context with a non-empty context +pub inline fip extern ".cctx-extend"( c : cctx, x : b, xhole : field-addr ) : cctx + c inline "kk_cctx_extend(#1,#2,#3,false /*is-linear*/,kk_context())" + js "_cctx_extend" + +// _Internal_. Compose a constructor context with a non-empty context +pub inline fip extern ".cctx-compose-extend"( c1 : cctx, c2 : cctx ) : cctx + c inline "kk_cctx_extend(#1,#2.res,#2.holeptr,false /*is-linear*/,kk_context())" + js "_cctx_compose" + +// Apply a constructor context +pub inline fip extern []( c : cctx, x : b ) : a + c inline "kk_cctx_apply(#1,#2,false /*is-linear*/,kk_context())" + js "_cctx_apply" + +// Apply a constructor context. +pub inline fip extern (++.)( c : cctx, x : b ) : a + c inline "kk_cctx_apply(#1,#2,false /*is-linear*/,kk_context())" + js "_cctx_apply" + +// Compose two constructor contexts. +pub inline fip extern (++)( c1 : cctx, c2 : cctx ) : cctx + c inline "kk_cctx_compose(#1,#2,false /*is-linear*/,kk_context())" + js "_cctx_compose" + +// Create an empty context +pub inline fip extern cctx-empty() : cctx + c "kk_cctx_empty" + js "_cctx_empty" + + diff --git a/lib/std/num/ddouble.kk b/lib/std/num/ddouble.kk index b3b3143df..65237b093 100644 --- a/lib/std/num/ddouble.kk +++ b/lib/std/num/ddouble.kk @@ -1,12 +1,12 @@ /*--------------------------------------------------------------------------- - Copyright 2017-2021, Microsoft Research, Daan Leijen. + Copyright 2017-2022, Microsoft Research, Daan Leijen. This is free software; you can redistribute it and/or modify it under the terms of the Apache License, Version 2.0. A copy of the License can be found in the LICENSE file at the root of this distribution. ---------------------------------------------------------------------------*/ -/* Double-double 128-bit floating point numbers. +/* 128-bit double-double floating point numbers. The `:ddouble` type implements [double double][ddwiki] 128-bit floating point numbers as a pair of IEEE `:float64` values. This extends the precision to 31 decimal digits @@ -87,14 +87,13 @@ exact : 3.14784204874900425235885265494550774498...e-16 ```` For this kind of example, a `:ddouble` has better precision than a regular 128-bit IEEE float since it can combine very large and -small values. (Kahan [@Kahan:triangle] shows how to rewrite the equations -to avoid magnifying rounding errors -- in that case the result for -IEEE 128-bit floats becomes: +small values. Note that Kahan [@Kahan:triangle] shows how to rewrite the area equation +to avoid magnifying rounding errors -- in that case the result for IEEE 128-bit floats becomes: ```` 128-bit ieee x : 3.147842048749004252358852654945507\([92210]{color:#F88}\)e-16 ```` -The implementation is based closely on the [QD] C++ library [@Hida:qd;@Hida:qdlib], +The implementation is based closely on the excellent [QD] C++ library [@Hida:qd;@Hida:qdlib], and assumes proper 64-bit IEEE `:float64`s with correct rounding. Integers can be represented precisely up to 30 decimal digits (and a bit more... up to 2^106^ - 2). @@ -166,7 +165,7 @@ import std/num/float64 import std/num/decimal import std/text/parse -/* The `:ddouble` type implements [float64 float64][ddwiki] 128-bit floating point numbers +/* The `:ddouble` type implements [double double][ddwiki] 128-bit floating point numbers as a pair of IEEE `:float64` values. This extends the precision to 31 decimal digits (versus 15 for `:float64`), but keeps the same range as a `:float64` with a maximum value of about 1.8·10^308^. Because @@ -176,7 +175,7 @@ than arbitrary precision floating point numbers. Internally a `:ddouble` _d_ is represented as a pair of `:float64`s, _hi_ and _lo_, such that the number represented by _d_ is _hi_+_lo_, where \|_lo_\| ≤ 0.5·ulp(_hi_). */ -abstract struct ddouble +abstract value struct ddouble hi : float64 lo : float64 @@ -379,7 +378,7 @@ pub fun max( x : ddouble, y : ddouble ) : ddouble Addition ------------------------------------------------------*/ -struct edouble +value struct edouble num : float64 err : float64 @@ -417,6 +416,11 @@ pub fun (+)( x : ddouble, y : ddouble ) : ddouble val e2 = z2.err + lo.err dquicksum(z2.num,e2) + +// Create a `:ddouble` as the sum of two `:float64`'s. +pub fun ddouble( x : float64, y : float64 ) : ddouble + if y.is-zero then ddouble(x) else dsum(x,y) + // Negate a `:ddouble`. pub fun (~)( x : ddouble ) : ddouble Ddouble(~x.hi,~x.lo) diff --git a/lib/std/num/decimal.kk b/lib/std/num/decimal.kk index dafc1028b..dbc7b20dd 100644 --- a/lib/std/num/decimal.kk +++ b/lib/std/num/decimal.kk @@ -19,10 +19,10 @@ import std/num/float64 // Type of a decimal number. Decimals have arbitrary precision and range and // do exact decimal arithmetic and are well suited for financial calculations for // example. -abstract struct decimal ( - num: int, - exp: int -) +abstract value struct decimal + num : int + exp : int + // The decimal zero. pub val zero : decimal = Decimal(0,0) diff --git a/lib/std/num/float64-inline.h b/lib/std/num/float64-inline.c similarity index 94% rename from lib/std/num/float64-inline.h rename to lib/std/num/float64-inline.c index 5918630bd..cd1e36b17 100644 --- a/lib/std/num/float64-inline.h +++ b/lib/std/num/float64-inline.c @@ -17,7 +17,7 @@ static inline double kk_double_from_bits( int64_t i, kk_context_t* ctx ) { } static inline double kk_prim_parse_double( kk_string_t str, kk_context_t* ctx) { - const char* s = kk_string_cbuf_borrow(str,NULL); + const char* s = kk_string_cbuf_borrow(str,NULL,ctx); char* end; double d = strtod(s,&end); kk_string_drop(str,ctx); diff --git a/lib/std/num/float64.kk b/lib/std/num/float64.kk index 223de40fb..a81ee1a09 100644 --- a/lib/std/num/float64.kk +++ b/lib/std/num/float64.kk @@ -18,7 +18,7 @@ import std/text/parse import std/num/int64 extern import - c file "float64-inline.h" + c file "float64-inline.c" js file "float64-inline.js" @@ -225,6 +225,7 @@ pub extern float64( f : float32 ) : float64 // > 1.337.show-hex ++ " != " ++ 1.337.f32.float64.show-hex // "0x1.5645A1CAC0831p+0 != 0x1.5645A2p+0" // ``` +// . pub fun f32( f : float64 ) : float32 f.float32 @@ -450,17 +451,16 @@ pub fun next-up( x : float64 ) : float64 // Compare floats using a total ordering on the `:float64`. // The ordering follows the `totalOrder` predicate as defined in IEEE 754-2008 exactly. // The values are ordered in following order: -// - negative quiet nan -// - negative signaling nan -// - `neginf` -// - -finite -// - -0.0 -// - +0.0 -// - finite -// - `posinf` -// - signaling nan -// - quiet nan -// +// negative quiet nan, +// negative signaling nan, +// `neginf`, +// -finite, +// -0.0, +// +0.0, +// finite, +// `posinf`, +// signaling nan, +// and quiet nan. pub fun compare( x : float64, y : float64 ) : order val bx = float64-to-bits(x) val by = float64-to-bits(y) @@ -470,6 +470,32 @@ pub fun compare( x : float64, y : float64 ) : order compare(ix,iy) +// The midpoint is the average of `x` and `y`. +// Avoids overflow on large numbers. +pub fun midpoint( x : float64, y : float64 ) : float64 + if is-subnormal(x) || is-subnormal(y) + then (x + y) / 2.0 + else (x / 2.0) + (y / 2.0) + + +// Linear interpolation, calculating `x + t*(y - x)` but avoids troublesome edge cases. +// Follows the C++20 [specification](http://www.open-std.org/jtc1/sc22/wg21/docs/papers/2019/p0811r3.html). +// In particular, if `x.is-finite && y.is-finite`, then: +// - exact: `lerp(x,y,0.0) == x` and `lerp(x,y,1.0) == y` +// - monotonic: if `x <= y` and `t1 <= t2`, then `compare( lerp(x,y,t1), lerp(x,y,t2) ) <= Eq` (and other cases) +// - deterministic: only `lerp(x,x,flt-inf)` results in `nan` +// - bounded: `t<0.0 || t>1.0 || is-finite(lerp(x,y,t))` +// - consistent: `lerp(x,x,t) == x` +pub fun lerp( x : float64, y : float64, t : float64 ) : float64 + if (x <= 0.0 && y >= 0.0) || (x >= 0.0 && y <= 0.0) then + t*y + (1.0 - t)*x + elif t == 1.0 then + y + else + val z = x + t*(y - x) + if ((t > 1.0) == (y > x)) then max(y,z) else min(y,z) + + //----------------------------------------- // Show in hexadecimal //----------------------------------------- @@ -566,6 +592,8 @@ extern prim-parse-float64( s : string ) : float64 // to minimize rounding errors. This // is more precise as Kahan summation and about as fast.\ // `[1.0e3,1.0e97,1.0e3,-1.0e97].sum == 2000.0`\ +// while\ +// `[1.0e3,1.0e97,1.0e3,-1.0e97].foldl(0.0,(+)) == 0.0` (!)\ // A. Neumaier, _Rundungsfehleranalyse einiger Verfahren zur Summation endlicher Summen_. // Math. Mechanik, 54:39--51, 1974. pub fun sum( xs : list ) : float64 diff --git a/lib/std/num/int32.kk b/lib/std/num/int32.kk index 46bfd9c04..f2e9cd12a 100644 --- a/lib/std/num/int32.kk +++ b/lib/std/num/int32.kk @@ -1,5 +1,5 @@ /*--------------------------------------------------------------------------- - Copyright 2012-2021, Microsoft Research, Daan Leijen. + Copyright 2012-2023, Microsoft Research, Daan Leijen. This is free software; you can redistribute it and/or modify it under the terms of the Apache License, Version 2.0. A copy of the License can be @@ -35,12 +35,12 @@ pub inline extern int32( f : float64 ) : int32 */ // Convert an `:int32` to a boolean. -pub fun bool( i : int32 ) : bool +pub fip fun bool( i : int32 ) : bool (i!=zero) // Convert a boolean to an `:int32`. -pub fun int32( b : bool ) : int32 +pub fip fun int32( b : bool ) : int32 if (b) then one else zero @@ -75,31 +75,31 @@ pub fun show-hex32( i : int32, width : int = 8, use-capitals : bool = True, pre std/core/show-hex(i.uint,width,use-capitals,pre) -pub inline extern (==) : (int32,int32) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } -pub inline extern (!=) : (int32,int32) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } -pub inline extern (<=) : (int32,int32) -> bool { inline "(#1 <= #2)" } -pub inline extern (>=) : (int32,int32) -> bool { inline "(#1 >= #2)" } -pub inline extern (<) : (int32,int32) -> bool { inline "(#1 < #2)" } -pub inline extern (>) : (int32,int32) -> bool { inline "(#1 > #2)" } +pub inline fip extern (==) : (int32,int32) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } +pub inline fip extern (!=) : (int32,int32) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } +pub inline fip extern (<=) : (int32,int32) -> bool { inline "(#1 <= #2)" } +pub inline fip extern (>=) : (int32,int32) -> bool { inline "(#1 >= #2)" } +pub inline fip extern (<) : (int32,int32) -> bool { inline "(#1 < #2)" } +pub inline fip extern (>) : (int32,int32) -> bool { inline "(#1 > #2)" } -pub inline extern (+) : (int32,int32) -> int32 - c inline "(int32_t)((uint32_t)#1 + (uint32_t)#2)" // avoid UB +pub inline fip extern (+) : (int32,int32) -> int32 + c inline "(int32_t)((uint32_t)#1 + (uint32_t)#2)" // avoid UB js inline "((#1 + #2)|0)" -pub inline extern (-) : (int32,int32) -> int32 +pub inline fip extern (-) : (int32,int32) -> int32 c inline "(int32_t)((uint32_t)#1 - (uint32_t)#2)" // avoid UB js inline "((#1 - #2)|0)" -pub inline extern is-neg( i : int32 ) : bool +pub inline fip extern is-neg( i : int32 ) : bool inline "0 > #1" -pub inline extern is-pos( i : int32 ) : bool +pub inline fip extern is-pos( i : int32 ) : bool inline "0 < #1" -pub inline extern is-zero( i : int32 ) : bool +pub inline fip extern is-zero( i : int32 ) : bool inline "0 == #1" js inline "0 === #1" @@ -107,39 +107,39 @@ pub inline extern is-zero( i : int32 ) : bool pub val zero = 0.int32 pub val one = 1.int32 -pub fun sign( i : int32 ) : order +pub fip fun sign( i : int32 ) : order if (i.is-pos) then Gt elif (i.is-neg) then Lt else Eq // Returns `true` if the integer `i` is an odd number. -pub fun is-odd( i : int32 ) : bool +pub fip fun is-odd( i : int32 ) : bool and(i,1.int32) == 1.int32 // Returns `true` if the integer `i` is an even number. -pub fun is-even( i : int32 ) : bool +pub fip fun is-even( i : int32 ) : bool and(i,1.int32) == 0.int32 // Increment a 32-bit integer. -pub fun inc( i : int32 ) : int32 +pub fip fun inc( i : int32 ) : int32 i + 1.int32 // Decrement a 32-bit integer. -pub fun dec( i : int32 ) : int32 +pub fip fun dec( i : int32 ) : int32 i - 1.int32 // Multiply two 32-bit integers. -pub inline extern (*) : (int32,int32) -> int32 +pub inline fip extern (*) : (int32,int32) -> int32 inline "(int32_t)((uint32_t)#1 * (uint32_t)#2)" // avoid UB js "$std_core._int32_multiply" -pub fun compare( x : int32, y : int32) : order +pub fip fun compare( x : int32, y : int32) : order if (x < y) then Lt elif (x > y) then Gt else Eq @@ -157,7 +157,7 @@ pub fun abs( i : int32 ) : exn int32 // Return the absolute value of an integer. // Returns 0 if the `:int32` is `min-int32` // (since the negation of `min-int32` equals itself and is still negative) -pub fun abs0( i : int32 ) : int32 +pub fip fun abs0( i : int32 ) : int32 if (!i.is-neg) then i elif (i > min-int32) then negate(i) else 0.int32 @@ -165,85 +165,137 @@ pub fun abs0( i : int32 ) : int32 // Take the bitwise _and_ of two `:int32`s -pub inline extern and : (int32,int32) -> int32 +pub inline fip extern and : (int32,int32) -> int32 inline "(#1 & #2)"; // Take the bitwise _or_ of two `:int32`s -pub inline extern or : (int32,int32) -> int32 +pub inline fip extern or : (int32,int32) -> int32 inline "(#1 | #2)"; // Take the bitwise _xor_ of two `:int32`s -pub inline extern xor : (int32,int32) -> int32 +pub inline fip extern xor : (int32,int32) -> int32 inline "(#1 ^ #2)"; // Take the bitwise _xor_ of two `:int32`s -pub fun(^)( x : int32, y : int32) : int32 +pub fip fun(^)( x : int32, y : int32) : int32 xor(x,y) // Bitwise _not_ of an `:int32`, i.e. flips all bits. -pub inline extern not : ( i : int32 ) -> int32 +pub inline fip extern not : ( i : int32 ) -> int32 inline "(~#1)" // Shift an `:int32` `i` to the left by `n & 31` bits. -inline extern shl32 : (int32,int32) -> int32 +inline fip extern shl32 : (int32,int32) -> int32 c inline "kk_shl32(#1,#2)" js inline "#1 << #2" // javascript masks the shift already // Shift an `:int32` `i` to the left by `n & 31` bits. -pub fun shl( i : int32, shift : int ) : int32 +pub fip fun shl( i : int32, shift : int ) : int32 shl32( i, shift.int32 ) // Logical shift an `:int32` to the right by `n % 32` bits. Shift in zeros from the left. -inline extern shr32 : (int32,int32) -> int32 +inline fip extern shr32 : (int32,int32) -> int32 c inline "(int32_t)kk_shr32(#1,#2)" cs inline "(Int32)(((UInt32)#1)>>#2)" js inline "#1 >>> #2" // Logical shift an `:int32` to the right by `n % 32` bits. Shift in zeros from the left. -pub fun shr( i : int32, shift : int ) : int32 +pub fip fun shr( i : int32, shift : int ) : int32 shr32( i, shift.int32 ) // Arithmetic shift an `:int32` to the right by `n % 32` bits. Shifts in the sign bit from the left. -inline extern sar32 : (int32,int32) -> int32 +inline fip extern sar32 : (int32,int32) -> int32 c inline "kk_sar32(#1,#2)" cs inline "(#1>>#2)" js inline "#1 >> #2" // Arithmetic shift an `:int32` to the right by `n % 32` bits. Shifts in the sign bit from the left. -pub fun sar( i : int32, shift : int ) : int32 +pub fip fun sar( i : int32, shift : int ) : int32 sar32( i, shift.int32 ) // Bitwise rotate an `:int32` `n % 32` bits to the left. -inline extern rotl32( i : int32, n : int32 ) : int32 +inline fip extern rotl32( i : int32, n : int32 ) : int32 c inline "(int32_t)kk_bits_rotl32(#1,#2)" js "$std_core._int32_rotl" // Bitwise rotate an `:int32` `n % 32` bits to the left. -pub fun rotl( i : int32, shift : int ) : int32 +pub fip fun rotl( i : int32, shift : int ) : int32 rotl32( i, shift.int32 ) // Bitwise rotate an `:int32` `n % 32` bits to the right. -inline extern rotr32( i : int32, n : int32 ) : int32 +inline fip extern rotr32( i : int32, n : int32 ) : int32 c inline "(int32_t)kk_bits_rotr32(#1,#2)" js "$std_core._int32_rotr" // Bitwise rotate an `:int32` `n % 32` bits to the right. -pub fun rotr( i : int32, shift : int ) : int32 +pub fip fun rotr( i : int32, shift : int ) : int32 rotr32( i, shift.int32 ) +// Count trailing zero bits. Returns 32 if `i` is zero. +inline fip extern ctz32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_ctz32(#1)" + js "$std_core._int32_ctz" + +// Count leading zero bits. Returns 32 if `i` is zero. +inline fip extern clz32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_clz32(#1)" + js "$std_core._int32_clz" + +// Count trailing zero bits. Returns 32 if `i` is zero. +pub fip fun ctz( i : int32 ) : int + ctz32(i).int + +// Count leading zero bits. Returns 32 if `i` is zero. +pub fip fun clz( i : int32 ) : int + clz32(i).int + +// Find first set: returns the bit-index + 1, or 0 when `i==0`. +inline fip extern ffs32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_ffs32(#1)" + js "$std_core._int32_ffs" + +// Find first set: returns the bit-index + 1, or 0 when `i==0`. +pub fip fun ffs( i : int32 ) : int + ffs32(i).int + +// Count leading redundant (i.e. the number of bits +// following the most significant bit that are identical to it). +inline fip extern clrsb32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_clrsb32(#1)" + js "$std_core._int32_clrsb" + +// Count leading redundant (i.e. the number of bits +// following the most significant bit that are identical to it). +pub fip fun clrsb( i : int32 ) : int + clrsb32(i).int + +// Count number of 1-bits. +inline fip extern popcount32( i : int32 ) : int32 + c inline "(int32_t)kk_bits_popcount32(#1)" + js "$std_core._int32_bits_popcount" + +// Count number of 1-bits. +pub fip fun popcount( i : int32 ) : int + popcount32(i).int + +// Is the number of 1-bits even? +pub inline fip extern parity( i : int32 ) : bool + c inline "kk_bits_popcount_is_even32(#1)" + js "$std_core._int32_parity" + // Return the minimum of two integers -pub fun min( i : int32, j : int32 ) : int32 +pub fip fun min( i : int32, j : int32 ) : int32 if (i <= j) then i else j // Return the maximum of two integers -pub fun max( i : int32, j : int32 ) : int32 +pub fip fun max( i : int32, j : int32 ) : int32 if (i >= j) then i else j @@ -263,31 +315,31 @@ pub fun cmod(i:int32, j:int32) : exn int32 // Truncated division (as in C). See also `(/):(x : int32, y : int32) -> int32`. -pub inline extern unsafe-cdiv : (int32,int32) -> int32 +pub inline fip extern unsafe-cdiv : (int32,int32) -> int32 inline "(#1 / #2)" js inline "((#1/#2)|0)" // Truncated modulus (as in C). See also `(%):(x : int32, y : int32) -> int32`. -pub inline extern unsafe-cmod : (int32,int32) -> int32 +pub inline fip extern unsafe-cmod : (int32,int32) -> int32 inline "(#1 % #2)" js inline "((#1 % #2)|0)" // Convert an 32-bit integer to a float64. -pub inline extern float64( i : int32) : float64 +pub inline fip extern float64( i : int32) : float64 c inline "(double)(#1)" cs inline "(double)(#1)" js inline "(#1)" // Negate a 32-bit integer -pub fun negate( i : int32 ) : int32 +pub fip fun negate( i : int32 ) : int32 (0.int32 - i) // Negate an 32-bit integer -pub fun (~)(i : int32) : total int32 +pub fip fun (~)(i : int32) : total int32 (0.int32 - i) @@ -314,7 +366,7 @@ Of course `(min-int32 + 1) / -1` is again positive (namely `max-int32`). See also _Division and modulus for computer scientists, Daan Leijen, 2001_ [pdf](http://research.microsoft.com/pubs/151917/divmodnote.pdf) . */ -pub fun (/)( x : int32, y : int32 ) : int32 +pub fip fun (/)( x : int32, y : int32 ) : int32 if (y == 0.int32) then return 0.int32 if (y == -1.int32 && x==min-int32) return x val q = unsafe-cdiv(x,y) @@ -325,7 +377,7 @@ pub fun (/)( x : int32, y : int32 ) : int32 // Euclidean-0 modulus. See `(/):(x : int32, y : int32) -> int32` division for more information. -pub fun (%)( x : int32, y : int32 ) : int32 +pub fip fun (%)( x : int32, y : int32 ) : int32 if (y == 0.int32) then return x if (y == -1.int32 && x==min-int32) return 0.int32 val r = unsafe-cmod(x,y) @@ -334,7 +386,7 @@ pub fun (%)( x : int32, y : int32 ) : int32 else (r - y) -pub fun divmod(x:int32,y:int32) : (int32,int32) +pub fip fun divmod(x:int32,y:int32) : (int32,int32) if (y.is-zero) then return (zero,x) if (y == -1.int32 && x==min-int32) return (x,0.int32) val q = unsafe-cdiv(x,y) @@ -344,8 +396,51 @@ pub fun divmod(x:int32,y:int32) : (int32,int32) else (q.inc,r - y) -pub fun fold-int32( start : int32, end : int32, init : a, f : (int32,a) -> e a ) : e a +pub fip fun fold-int32( start : int32, end : int32, init : a, ^f : (int32,a) -> e a ) : e a if (start >= end) then init else val x = f(start,init) fold-int32(unsafe-decreasing(start.inc), end, x, f) +pub fun fold-while-int32( start : int32, end : int32, init : a, f : (int32,a) -> e maybe ) : e a + if (start >= end) then init else + match f(start,init) + Just(x) -> fold-while-int32(unsafe-decreasing(start.inc), end, x, f) + Nothing -> init + + +// Executes `action` for each integer between `start` upto `end` (including both `start` and `end` ). +// If `start > end` the function returns without any call to `action` . +pub fun for32( start: int32, end : int32, action : (int32) -> e () ) : e () + fun rep( i : int32 ) + if i <= end then + action(i) + rep(unsafe-decreasing(i.inc)) + rep(start) + + +// Executes `action` for each integer between `start` upto `end` (including both `start` and `end` ). +// If `start > end` the function returns without any call to `action` . +// If `action` returns `Just`, the iteration is stopped and the result returned +pub fun for-while32( start: int32, end : int32, action : (int32) -> e maybe ) : e maybe + fun rep( i : int32 ) + if i <= end then + match action(i) + Nothing -> rep(unsafe-decreasing(i.inc)) + Just(x) -> Just(x) + else Nothing + rep(start) + +pub fun list32( lo: int32, hi: int32 ) : total list + if lo <= hi + then Cons( lo, list32( unsafe-decreasing(lo.inc), hi ) ) + else Nil + +pub fip fun sum32( ^xs : list ) : int32 + // xs.foldl( 0.int32, fn(x,y) x + y ) + sumacc32(xs,0.int32) + +fip fun sumacc32( ^xs : list, acc : int32 ) : int32 + match xs + Cons(x,xx) -> sumacc32(xx,acc+x) + Nil -> acc + diff --git a/lib/std/num/int64.kk b/lib/std/num/int64.kk index 73e47d706..21652bc45 100644 --- a/lib/std/num/int64.kk +++ b/lib/std/num/int64.kk @@ -1,5 +1,5 @@ /*--------------------------------------------------------------------------- - Copyright 2012-2021, Microsoft Research, Daan Leijen. + Copyright 2012-2023, Microsoft Research, Daan Leijen. This is free software; you can redistribute it and/or modify it under the terms of the Apache License, Version 2.0. A copy of the License can be @@ -32,23 +32,23 @@ pub fun bool( i : int64 ) : bool // Convert a boolean to an `:int64`. -pub fun int64( b : bool ) : int64 +pub fip fun int64( b : bool ) : int64 if b then one else zero // Convert an `:int32` to an `:int64` (using sign extension). -pub inline extern int64( i : int32 ) : int64 +pub inline fip extern int64( i : int32 ) : int64 c inline "(int64_t)(#1)" js "$std_core._int64_from_int32" // Convert an `:int32` to an `:int64` interpreting the `:int32` as unsigned. -pub inline extern uint64( i : int32 ) : int64 +pub inline fip extern uint64( i : int32 ) : int64 c inline "(int64_t)((uint32_t)(#1))" js "$std_core._int64_from_uint32" // Clamp an `:int64` to an `:int32` // `-1.int64.int32 == -1.int32` // `0x8000_0000.int64.int32 == 0x7FFF_FFFF.int32` (clamped) -pub inline extern int32( i : int64 ) : int32 +pub inline fip extern int32( i : int64 ) : int32 c "kk_int64_clamp_int32" js "$std_core._int64_clamp_int32" @@ -56,13 +56,13 @@ pub inline extern int32( i : int64 ) : int32 // (and thus clamp between 0 and 0xFFFFFFFF). // `-1.int64.uint32 == 0.int32` (clamped) // `0xFFFFFFFF.int64.uint32 == -1.int32` -pub inline extern uint32( i : int64 ) : int32 +pub inline fip extern uint32( i : int64 ) : int32 c "kk_int64_clamp_uint32" js "$std_core._int64_clamp_uint32" // Create an `:int64` `i` from the bits of `lo` and `hi` such // that `i.int = hi.int * 0x1_0000_0000 + lo.uint`. -pub fun int64( lo : int32, hi : int32 ) : int64 +pub fip fun int64( lo : int32, hi : int32 ) : int64 hi.int64.shl(32).or(lo.uint64) // Convert an `:int` to `:int64` but interpret the `int` as an unsigned 64-bit value. @@ -75,7 +75,7 @@ pub fun uint64( i : int ) : int64 // Convert an `:int64` to an `:int` but interpret the `:int64` as a 64-bit unsigned value. -pub fun uint( i : int64 ) : int +pub fip fun uint( i : int64 ) : int if i.is-neg then 0x1_0000_0000_0000_0000 + i.int else i.int @@ -94,34 +94,34 @@ pub fun show-hex64( i : int64, width : int = 16, use-capitals : bool = True, pre std/core/show-hex(i.uint,width,use-capitals,pre) -pub inline extern (<=) : (int64,int64) -> bool { inline "(#1 <= #2)" } -pub inline extern (==) : (int64,int64) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } -pub inline extern (!=) : (int64,int64) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } -pub inline extern (>=) : (int64,int64) -> bool { inline "(#1 >= #2)" } -pub inline extern (<) : (int64,int64) -> bool { inline "(#1 < #2)" } -pub inline extern (>) : (int64,int64) -> bool { inline "(#1 > #2)" } +pub inline fip extern (<=) : (int64,int64) -> bool { inline "(#1 <= #2)" } +pub inline fip extern (==) : (int64,int64) -> bool { inline "(#1 == #2)"; js inline "(#1 === #2)" } +pub inline fip extern (!=) : (int64,int64) -> bool { inline "(#1 != #2)"; js inline "(#1 !== #2)" } +pub inline fip extern (>=) : (int64,int64) -> bool { inline "(#1 >= #2)" } +pub inline fip extern (<) : (int64,int64) -> bool { inline "(#1 < #2)" } +pub inline fip extern (>) : (int64,int64) -> bool { inline "(#1 > #2)" } -pub inline extern (+) : (int64,int64) -> int64 +pub inline fip extern (+) : (int64,int64) -> int64 c inline "(int64_t)((uint64_t)#1 + (uint64_t)#2)" js inline "BigInt.asIntN(64,#1 + #2)" -pub inline extern (-) : (int64,int64) -> int64 +pub inline fip extern (-) : (int64,int64) -> int64 inline "(int64_t)((uint64_t)#1 - (uint64_t)#2)" js inline "BigInt.asIntN(64,#1 - #2)" -pub inline extern is-neg( i : int64 ) : bool +pub inline fip extern is-neg( i : int64 ) : bool inline "0 > #1" js inline "0n > #1" -pub inline extern is-pos( i : int64 ) : bool +pub inline fip extern is-pos( i : int64 ) : bool inline "0 < #1" js inline "0n < #1" -pub inline extern is-zero( i : int64 ) : bool +pub inline fip extern is-zero( i : int64 ) : bool inline "0 == #1" js inline "0n === #1" @@ -129,39 +129,39 @@ pub inline extern is-zero( i : int64 ) : bool pub val zero = 0.int64 pub val one = 1.int64 -pub fun sign( i : int64 ) : order +pub fip fun sign( i : int64 ) : order if i.is-pos then Gt elif i.is-neg then Lt else Eq // Returns `true` if the integer `i` is an odd number. -pub fun is-odd( i : int64 ) : bool +pub fip fun is-odd( i : int64 ) : bool and(i,one)==one // Returns `true` if the integer `i` is an even number. -pub fun is-even( i : int64 ) : bool +pub fip fun is-even( i : int64 ) : bool and(i,one)==zero // Increment a 64-bit integer. -pub fun inc( i : int64 ) : int64 +pub fip fun inc( i : int64 ) : int64 i + 1.int64 // Decrement a 64-bit integer. -pub fun dec( i : int64 ) : int64 +pub fip fun dec( i : int64 ) : int64 i - 1.int64 // Multiply two 64-bit integers. -pub inline extern (*) : (int64,int64) -> int64 +pub inline fip extern (*) : (int64,int64) -> int64 c inline "(int64_t)((uint64_t)#1 * (uint64_t)#2)"; js inline "BigInt.asIntN(64,#1 * #2)" -pub fun compare( x : int64, y : int64) : order +pub fip fun compare( x : int64, y : int64) : order if x < y then Lt elif x > y then Gt else Eq @@ -179,7 +179,7 @@ pub fun abs( i : int64 ) : exn int64 // Return the absolute value of an integer. // Returns 0 if the `:int64` is `min-int64` // (since the negation of `min-int64` equals itself and is still negative) -pub fun abs0( i : int64 ) : int64 +pub fip fun abs0( i : int64 ) : int64 if !i.is-neg then i elif i > min-int64 then negate(i) else 0.int64 @@ -187,58 +187,58 @@ pub fun abs0( i : int64 ) : int64 // Take the bitwise _and_ of two `:int64`s -pub inline extern and : (int64,int64) -> int64 +pub inline fip extern and : (int64,int64) -> int64 inline "#1 & #2" // Take the bitwise _or_ of two `:int64`s -pub inline extern or : (int64,int64) -> int64 +pub inline fip extern or : (int64,int64) -> int64 inline "#1 | #2" // Take the bitwise _xor_ of two `:int64`s -pub inline extern xor : (int64,int64) -> int64 +pub inline fip extern xor : (int64,int64) -> int64 inline "#1 ^ #2"; // Take the bitwise _xor_ of two `:int64`s -pub fun(^)( x : int64, y : int64) : int64 +pub fip fun (^)( x : int64, y : int64) : int64 xor(x,y) // Bitwise _not_ of an `:int64`, i.e. flips all bits. -pub inline extern not : ( i : int64 ) -> int64 +pub inline fip extern not : ( i : int64 ) -> int64 inline "~#1" js inline "BigInt.asIntN(64, ~#1)" // Shift an `:int64` `i` to the left by `n % 64` bits. -inline extern shl64 : (int64,int64) -> int64 +inline fip extern shl64 : (int64,int64) -> int64 c inline "kk_shl64(#1,#2)" js "$std_core._int64_shl" // Shift an `:int64` `i` to the left by `n % 64` bits. -pub fun shl( i : int64, shift : int) : int64 +pub fip fun shl( i : int64, shift : int) : int64 shl64(i,shift.int64) // Logical shift an `:int64` to the right by `n % 64` bits. Shift in zeros from the left. -inline extern shr64 : (int64,int64) -> int64 +inline fip extern shr64 : (int64,int64) -> int64 c inline "(int64_t)kk_shr64(#1,#2)" cs inline "(int64)(((Uint64)#1)>>#2)" js "$std_core._int64_shr" // Logical shift an `:int64` to the right by `n % 64` bits. Shift in zeros from the left. -pub fun shr( i : int64, shift : int) : int64 +pub fip fun shr( i : int64, shift : int) : int64 shr64(i,shift.int64) // Arithmetic shift an `:int64` to the right by `n % 64` bits. Preserves the sign bit. -inline extern sar64 : (int64,int64) -> int64 +inline fip extern sar64 : (int64,int64) -> int64 c inline "kk_sar64(#1,#2)" js "$std_core._int64_sar" // Arithmetic shift an `:int64` to the right by `n % 64` bits. Shift in the sign bit from the left. -pub fun sar( i : int64, shift : int) : int64 +pub fip fun sar( i : int64, shift : int) : int64 sar64(i,shift.int64) // Bitwise rotate an `:int64` `n % 64` bits to the left. -inline extern rotl64( i : int64, n : int64 ) : int64 +inline fip extern rotl64( i : int64, n : int64 ) : int64 c inline "(int64_t)kk_bits_rotl64(#1,#2)" js "$std_core._int64_rotl" @@ -247,21 +247,75 @@ pub fun rotl( i : int64, shift : int) : int64 rotl64(i,shift.int64) // Bitwise rotate an `:int64` `n % 64` bits to the right. -inline extern rotr64( i : int64, n : int64 ) : int64 +inline fip extern rotr64( i : int64, n : int64 ) : int64 c inline "(int64_t)kk_bits_rotr64(#1,#2)" js "$std_core._int64_rotr" // Bitwise rotate an `:int64` `n % 64` bits to the right. -pub fun rotr( i : int64, shift : int) : int64 +pub fip fun rotr( i : int64, shift : int) : int64 rotr64(i,shift.int64) +// Count trailing zero bits. Returns 64 if `i` is zero. +inline fip extern ctz64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_ctz64(#1)" + js "$std_core._int64_ctz" + +// Count leading zero bits. Returns 64 if `i` is zero. +inline fip extern clz64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_clz64(#1)" + js "$std_core._int64_clz" + +// Find first set: returns the bit-index + 1, or 0 when `i==0`. +inline fip extern ffs64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_ffs64(#1)" + js "$std_core._int64_ffs" + +// Count leading redundant (i.e. the number of bits +// following the most significant bit that are identical to it). +inline fip extern clrsb64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_clrsb64(#1)" + js "$std_core._int64_clrsb" + +// Count trailing zero bits. Returns 64 if `i` is zero. +pub fip fun ctz( i : int64 ) : int + ctz64(i).int + +// Count leading zero bits. Returns 64 if `i` is zero. +pub fip fun clz( i : int64 ) : int + clz64(i).int + +// Find first set: returns the bit-index + 1, or 0 when `i==0`. +pub fip fun ffs( i : int64 ) : int + ffs64(i).int + +// Count leading redundant (i.e. the number of bits +// following the most significant bit that are identical to it). +pub fip fun clrsb( i : int64 ) : int + clrsb64(i).int + + +// Count number of 1-bits. +inline fip extern popcount64( i : int64 ) : int64 + c inline "(int64_t)kk_bits_popcount64(#1)" + js "$std_core._int64_popcount" + +// Count number of 1-bits. +pub fip fun popcount( i : int64 ) : int + popcount64(i).int + +// Is the number of 1-bits even? +pub inline fip extern parity( i : int64 ) : bool + c inline "kk_bits_popcount_is_even64(#1)" + js "$std_core._int64_parity" + + // Return the minimum of two integers -pub fun min( i : int64, j : int64 ) : int64 +pub fip fun min( i : int64, j : int64 ) : int64 if i <= j then i else j // Return the maximum of two integers -pub fun max( i : int64, j : int64 ) : int64 +pub fip fun max( i : int64, j : int64 ) : int64 if i >= j then i else j @@ -280,27 +334,27 @@ pub fun cmod(i:int64, j:int64) : exn int64 // Truncated division (as in C). See also `(/):(x : int64, y : int64) -> int64`. -inline extern unsafe-cdiv : (int64,int64) -> int64 +inline fip extern unsafe-cdiv : (int64,int64) -> int64 inline "#1 / #2" // Truncated modulus (as in C). See also `(%):(x : int64, y : int64) -> int64`. -inline extern unsafe-cmod : (int64,int64) -> int64 +inline fip extern unsafe-cmod : (int64,int64) -> int64 inline "#1 % #2" // Convert an 64-bit integer to a `:float64`. -pub fun float64( i : int64 ) : float64 +pub fip fun float64( i : int64 ) : float64 i.int.float64 // Negate a 64-bit integer -pub fun negate( i : int64 ) : int64 +pub fip fun negate( i : int64 ) : int64 0.int64 - i // Negate an 64-bit integer -pub fun (~)(i : int64) : total int64 +pub fip fun (~)(i : int64) : total int64 0.int64 - i @@ -327,7 +381,7 @@ Of course `(min-int64 + 1) / -1` is again positive (namely `max-int64`). See also _Division and modulus for computer scientists, Daan Leijen, 2001_ [pdf](http://research.microsoft.com/pubs/151917/divmodnote.pdf) . */ -pub fun (/)( x : int64, y : int64 ) : int64 +pub fip fun (/)( x : int64, y : int64 ) : int64 if y == 0.int64 return 0.int64 if y == -1.int64 && x==min-int64 return x val q = unsafe-cdiv(x,y) @@ -338,7 +392,7 @@ pub fun (/)( x : int64, y : int64 ) : int64 // Euclidean-0 modulus. See `(/):(x : int64, y : int64) -> int64` division for more information. -pub fun (%)( x : int64, y : int64 ) : int64 +pub fip fun (%)( x : int64, y : int64 ) : int64 if y == 0.int64 return x if y == -1.int64 && x==min-int64 return 0.int64 val r = unsafe-cmod(x,y) @@ -346,7 +400,7 @@ pub fun (%)( x : int64, y : int64 ) : int64 elif y > 0.int64 then r + y else r - y -pub fun divmod( x :int64, y :int64 ) : (int64,int64) +pub fip fun divmod( x :int64, y :int64 ) : (int64,int64) if y.is-zero return (zero,x) if y == -1.int64 && x==min-int64 return (x,0.int64) val q = unsafe-cdiv(x,y) @@ -360,3 +414,30 @@ pub fun fold-int64( start : int64, end : int64, init : a, f : (int64,a) -> e a ) if start >= end then init else val x = f(start,init) fold-int64(unsafe-decreasing(start.inc), end, x, f) + +// Executes `action` for each integer between `start` upto `end` (including both `start` and `end` ). +// If `start > end` the function returns without any call to `action` . +// If `action` returns `Just`, the iteration is stopped and the result returned +pub fun for-while64( start: int64, end : int64, ^action : (int64) -> e maybe ) : e maybe + fun rep( i : int64 ) + if i <= end then + match action(i) + Nothing -> rep(unsafe-decreasing(i.inc)) + Just(x) -> Just(x) + else Nothing + rep(start) + +pub fun list64( lo: int64, hi: int64 ) : total list + if lo <= hi + then Cons( lo, list64( unsafe-decreasing(lo.inc), hi ) ) + else Nil + +pub fun sum64( xs : list ) : int64 + // xs.foldl( 0.int64, fn(x,y) x + y ) + sumacc64(xs,0.int64) + +fun sumacc64( xs : list, acc : int64 ) : int64 + match xs + Cons(x,xx) -> sumacc64(xx,acc+x) + Nil -> acc + diff --git a/lib/std/num/random.kk b/lib/std/num/random.kk index a975b5563..046478239 100644 --- a/lib/std/num/random.kk +++ b/lib/std/num/random.kk @@ -39,21 +39,27 @@ pub fun strong-random(action : () -> a) : a // The chance of a cycle of less than 2^(32+max(96-k,0)) is 2^-(32+k), // (e.g. the chance of a cycle of less than 2^48 is 2^-80). // -struct sfc(x:int32, y:int32, z:int32, cnt:int32) +abstract value struct sfc(x:int32, y:int32, z:int32, cnt:int32) -fun sfc-step( sfc : sfc ) : (int32,sfc) +pub value struct sfc-result( rnd : int32, rstate : sfc ) + +pub fun sfc-step( sfc : sfc ) : sfc-result match sfc Sfc(x,y,z,cnt) -> val res = x + y + cnt - (res, Sfc( y ^ shr(y,9), - z + shl(z,3), - rotl(z,21) + res, - cnt + 1.int32 )) + Sfc-result( res, Sfc( y ^ shr(y,9), + z + shl(z,3), + rotl(z,21) + res, + cnt + 1.int32 )) + +pub fun sfc-init32( seed1 : int32, seed2 : int32 ) : sfc + val sfc0 = Sfc(0.int32, seed1, seed2, 1.int32) + fold-int32( 0.int32, 12.int32, sfc0, fn(_,s){ sfc-step(s).rstate } ) // step 12 times -fun sfc-init( seed : int ) : sfc - val sfc0 = Sfc(0.int32, seed.int32, (seed / 0x100000000).int32, 1.int32) - fold-int32( 0.int32, 12.int32, sfc0, fn(_,s){ sfc-step(s).snd } ) // step 12 times +pub fun sfc-init( seed : int ) : sfc + sfc-init32(seed.int32, (seed / 0x100000000).int32) + // Use pseudo random numbers given some initial `seed`. At most // 64-bits of the initial seed are used. Do not use this for @@ -66,9 +72,9 @@ fun sfc-init( seed : int ) : sfc pub fun pseudo-random( seed : int, action : () -> a) : e a var s := sfc-init(seed) with fun random-int32() - val (x,sfc) = sfc-step(s) - s := sfc - x + val sfc = sfc-step(s) + s := sfc.rstate + sfc.rnd action() diff --git a/lib/std/os/env.kk b/lib/std/os/env.kk index 79fcb4626..2faaa636b 100644 --- a/lib/std/os/env.kk +++ b/lib/std/os/env.kk @@ -98,25 +98,37 @@ pub extern get-cpu-is-little-endian() : ndet bool c "kk_cpu_is_little_endian" js inline "true" -// Return the processor architecture natural machine word size in bits. +// Return the processor natural integer register size in bits. // -// Note: Usually this equals the `get-cpu-object-bits` and `get-cpu-address-bits` on modern cpu's +// Note: Usually this equals the `get-cpu-size-bits` and `get-cpu-pointer-bits` on modern cpu's // but they can differ on segmented architectures. // For example, on the old x86 FAR-NEAR model, the addresses are 32-bit but the maximum object size is 16-bit. // Or on the more recent-[x32 ABI](https://en.wikipedia.org/wiki/X32_ABI) // the addresses and objects are 32-bits but the architecture has 64-bit registers. -pub extern get-cpu-arch-bits() : ndet int - c inline "kk_integer_from_size_t(CHAR_BIT*(sizeof(size_t) > sizeof(long) ? sizeof(size_t) : sizeof(long)),kk_context())" +pub extern get-cpu-int-bits() : ndet int + c inline "kk_integer_from_size_t(CHAR_BIT*sizeof(kk_intx_t),kk_context())" js inline "32" // Return the processor maximum object size in bits (`8*sizeof(size_t)`). This is usually // equal to the `get-cpu-arch-bits` but may be different on segmented architectures. -pub extern get-cpu-object-bits() : ndet int +pub extern get-cpu-size-bits() : ndet int c inline "kk_integer_from_size_t(CHAR_BIT*sizeof(size_t),kk_context())" js inline "32" -// Return the processor maximum address size in bits (`8*sizeof(void*)`). This is usually -// equal to the `get-cpu-arch-bits` but may be different on segmented architectures. +// Return the processor maximum address size in bits (`8*sizeof(vaddr_t)`). This is usually +// equal to the `get-cpu-pointer-bits` but may be smaller on capability architectures like ARM CHERI. pub extern get-cpu-address-bits() : ndet int + c inline "kk_integer_from_int(kk_cpu_address_bits(kk_context()),kk_context())" + js inline "32" + +// Return the processor maximum pointer size in bits (`8*sizeof(void*)`). This is usually +// equal to the `get-cpu-address-bits` but may be larger on capability architectures like ARM CHERI. +pub extern get-cpu-pointer-bits() : ndet int c inline "kk_integer_from_size_t(CHAR_BIT*sizeof(void*),kk_context())" js inline "32" + +// Return the size of boxed values in the heap (`8*sizeof(kk_box_t)`). This is usually +// equal to `8*sizeof(void*)` but can be less if compressed pointers are used. +pub extern get-cpu-boxed-bits() : ndet int + c inline "kk_integer_from_size_t(CHAR_BIT*sizeof(kk_intb_t),kk_context())" + js inline "32" diff --git a/lib/std/os/flags.kk b/lib/std/os/flags.kk index f75a0631d..ad8a77c82 100644 --- a/lib/std/os/flags.kk +++ b/lib/std/os/flags.kk @@ -115,33 +115,33 @@ pub fun test( cmdargs ) // Specifies how to handle flags that follow non-flag command line arguments. -pub type flag-order +pub value type flag-order // Allow flags to be permuted with non-flag arguments (default) - con Permute + Permute // flags following non-flag arguments are treated as arguments - con Preorder + Preorder // Wrap each non-flag argument into an flag - con Wrap( wrap : (string) -> a ) + Wrap( wrap : (string) -> a ) // Specifies a single command line flag // For example: `flag("h?",["help"],Bool(Help),"show help information")`. -pub struct flag( - short-names : string, - long-names : list, - parser : flag-parser, +pub struct flag + short-names : string + long-names : list + parser : flag-parser help : string -) + // Specifies the argument of an flag pub type flag-parser // Boolean flag without an argument. // For a flag `foo` Automatically enables forms `--no-foo` and `--foo=true|false`. - con Bool( default : (a,bool) -> a) + Bool( default : (a,bool) -> a) // A required argument. - con Req( parse : (a,string) -> a, help : string ) + Req( parse : (a,string) -> a, help : string ) // An flagal argument. - con Opt( parse : (a,maybe) -> a, help : string ) + Opt( parse : (a,maybe) -> a, help : string ) // Return a nicely formatted string describing the usage of a command, @@ -182,7 +182,7 @@ fun show-long-flag( parser : flag-parser ) Opt( help=h ) -> "[=" ++ h ++ "]" -type flag-kind +value type flag-kind Flg( set : a -> a ) Arg( arg : string ) End diff --git a/lib/std/os/path.kk b/lib/std/os/path.kk index a036f8415..b8c96e2fd 100644 --- a/lib/std/os/path.kk +++ b/lib/std/os/path.kk @@ -38,10 +38,10 @@ extern import js file "path-inline.js" // A `:path` represents a file system path.\ -abstract struct path( - root : string = "", +abstract value struct path + root : string = "" parts: list = [] // directory parts in reverse order -) + // Return the base name of a path (stem name + extension)\ // `"/foo/bar.txt".path.basename === "bar.txt"` \ diff --git a/lib/std/text/regex-inline.c b/lib/std/text/regex-inline.c index 3b8a087e2..5eda893e8 100644 --- a/lib/std/text/regex-inline.c +++ b/lib/std/text/regex-inline.c @@ -66,7 +66,7 @@ static void kk_regex_free( void* pre, kk_block_t* b, kk_context_t* ctx ) { kk_unused(ctx); pcre2_code* re = (pcre2_code*)pre; //kk_info_message( "free regex at %p\n", re ); - if (re != NULL) pcre2_code_free(re); + if (re != NULL) { pcre2_code_free(re); } } #define KK_REGEX_OPTIONS (PCRE2_ALT_BSUX | PCRE2_EXTRA_ALT_BSUX | PCRE2_MATCH_UNSET_BACKREF /* javascript compat */ \ @@ -75,7 +75,7 @@ static void kk_regex_free( void* pre, kk_block_t* b, kk_context_t* ctx ) { static kk_box_t kk_regex_create( kk_string_t pat, bool ignore_case, bool multi_line, kk_context_t* ctx ) { kk_ssize_t len; - const uint8_t* cpat = kk_string_buf_borrow( pat, &len ); + const uint8_t* cpat = kk_string_buf_borrow( pat, &len, ctx ); PCRE2_SIZE errofs = 0; int errnum = 0; uint32_t options = KK_REGEX_OPTIONS; @@ -119,8 +119,8 @@ static kk_std_core__list kk_regex_exec_ex( pcre2_code* re, pcre2_match_data* mat kk_ssize_t sstart = groups[i*2]; // on no-match, sstart and send == -1. kk_ssize_t send = groups[i*2 + 1]; kk_assert(send >= sstart); - kk_std_core__sslice sslice = kk_std_core__new_Sslice( kk_string_dup(str_borrow), sstart, send - sstart, ctx ); - hd = kk_std_core__new_Cons(kk_reuse_null,kk_std_core__sslice_box(sslice,ctx), hd, ctx); + kk_std_core__sslice sslice = kk_std_core__new_Sslice( kk_string_dup(str_borrow,ctx), kk_integer_from_ssize_t(sstart,ctx), kk_integer_from_ssize_t(send - sstart,ctx), ctx ); + hd = kk_std_core__new_Cons(kk_reuse_null,0,kk_std_core__sslice_box(sslice,ctx), hd, ctx); if (i == 0) { if (mstart != NULL) { *mstart = sstart; } if (end != NULL) { *end = send; } @@ -136,13 +136,13 @@ static kk_std_core__list kk_regex_exec( kk_box_t bre, kk_string_t str, kk_ssize_ // unpack pcre2_match_data* match_data = NULL; kk_std_core__list res = kk_std_core__new_Nil(ctx); - pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre); + pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox_borrowed(bre,ctx); kk_ssize_t len = 0; const uint8_t* cstr = NULL; if (re == NULL) goto done; match_data = pcre2_match_data_create_from_pattern(re, gen_ctx); if (match_data==NULL) goto done; - cstr = kk_string_buf_borrow(str, &len ); + cstr = kk_string_buf_borrow(str, &len, ctx ); // and match res = kk_regex_exec_ex( re, match_data, str, cstr, len, true, start, NULL, NULL, NULL, ctx ); @@ -162,13 +162,13 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss if (atmost < 0) atmost = KK_SSIZE_MAX; pcre2_match_data* match_data = NULL; kk_std_core__list res = kk_std_core__new_Nil(ctx); - pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox(bre); + pcre2_code* re = (pcre2_code*)kk_cptr_raw_unbox_borrowed(bre,ctx); if (re == NULL) goto done; match_data = pcre2_match_data_create_from_pattern(re, gen_ctx); if (match_data==NULL) goto done; { kk_ssize_t len; - const uint8_t* cstr = kk_string_buf_borrow(str, &len ); + const uint8_t* cstr = kk_string_buf_borrow(str, &len, ctx ); // and match kk_std_core__list* tail = NULL; @@ -183,13 +183,13 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss if (rc > 0) { // found a match; // push string up to match, and the actual matched regex - kk_std_core__sslice pre = kk_std_core__new_Sslice( kk_string_dup(str), start, mstart - start, ctx ); - kk_std_core__list prelist = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__sslice_box(pre,ctx), kk_std_core__new_Nil(ctx), ctx ); - kk_std_core__list capcons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(cap,ctx), kk_std_core__new_Nil(ctx) /*tail*/, ctx ); - kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(prelist,ctx), capcons, ctx ); + kk_std_core__sslice pre = kk_std_core__new_Sslice( kk_string_dup(str,ctx), kk_integer_from_ssize_t(start,ctx), kk_integer_from_ssize_t(mstart - start,ctx), ctx ); + kk_std_core__list prelist = kk_std_core__new_Cons( kk_reuse_null, 0, kk_std_core__sslice_box(pre,ctx), kk_std_core__new_Nil(ctx), ctx ); + kk_std_core__list capcons = kk_std_core__new_Cons( kk_reuse_null, 0, kk_std_core__list_box(cap,ctx), kk_std_core__new_Nil(ctx) /*tail*/, ctx ); + kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, 0, kk_std_core__list_box(prelist,ctx), capcons, ctx ); if (tail==NULL) res = cons; else *tail = cons; - tail = &kk_std_core__as_Cons(capcons)->tail; + tail = &kk_std_core__as_Cons(capcons,ctx)->tail; allow_empty = (next > start); start = next; } @@ -204,9 +204,9 @@ static kk_std_core__list kk_regex_exec_all( kk_box_t bre, kk_string_t str, kk_ss } // push final string part as well and end the list - kk_std_core__sslice post = kk_std_core__new_Sslice( kk_string_dup(str), next, len - next, ctx ); - kk_std_core__list postlist= kk_std_core__new_Cons( kk_reuse_null, kk_std_core__sslice_box(post,ctx), kk_std_core__new_Nil(ctx), ctx ); - kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, kk_std_core__list_box(postlist,ctx), kk_std_core__new_Nil(ctx), ctx ); + kk_std_core__sslice post = kk_std_core__new_Sslice( kk_string_dup(str,ctx), kk_integer_from_ssize_t(next,ctx), kk_integer_from_ssize_t(len - next,ctx), ctx ); + kk_std_core__list postlist= kk_std_core__new_Cons( kk_reuse_null, 0, kk_std_core__sslice_box(post,ctx), kk_std_core__new_Nil(ctx), ctx ); + kk_std_core__list cons = kk_std_core__new_Cons( kk_reuse_null, 0, kk_std_core__list_box(postlist,ctx), kk_std_core__new_Nil(ctx), ctx ); if (tail==NULL) res = cons; else *tail = cons; } diff --git a/lib/std/text/regex.kk b/lib/std/text/regex.kk index 99e4afa5e..3dc1af405 100644 --- a/lib/std/text/regex.kk +++ b/lib/std/text/regex.kk @@ -7,7 +7,7 @@ ---------------------------------------------------------------------------*/ /* Regular expressions. - + The regular expressions conform to the regular expressions of JavaScript as described at */ @@ -25,7 +25,7 @@ extern import // Abstract type of a regular expression object -abstract struct regex( obj: any, src : string ) +abstract value struct regex( obj: any, src : string ) // Return the pattern as a string pub fun source( r : regex ) : string diff --git a/lib/std/time/calendar.kk b/lib/std/time/calendar.kk index 81f71d31f..8d29dc97e 100644 --- a/lib/std/time/calendar.kk +++ b/lib/std/time/calendar.kk @@ -27,17 +27,17 @@ extern import js file "calendar-inline.js" // A Calendar determines how a `:date` and `:clock` relates to an `:instant` in time. -abstract struct calendar( - pub name : string, - pub long-name : string, - //timescale : timescale, - pub month-prefix: string, - pub show-era : (date) -> string, - instant-to-dc : (i:instant,tzdelta:duration) -> (date,clock), - dc-to-instant : (date,clock,timezone,timescale) -> instant, - days-to-date : (days:int) -> date, +abstract struct calendar + pub name : string + pub long-name : string + //timescale : timescale + pub month-prefix: string + pub show-era : (date) -> string + instant-to-dc : (i:instant,tzdelta:duration) -> (date,clock) + dc-to-instant : (date,clock,timezone,timescale) -> instant + days-to-date : (days:int) -> date date-to-days : (date:date) -> int -) + // Check if two calendars use the same date calculations. (Display of era names etc. may differ) pub fun (==)( c1 : calendar, c2 : calendar ) : bool @@ -57,11 +57,11 @@ pub fun (==)( c1 : calendar, c2 : calendar ) : bool // The optional `utc-inverse` field returns for an instant in the time zone, the associated UTC time. // By default it returns `Nothing` in which case a generic algorithm is used to determine the // inverse. -abstract struct timezone( - pub name : string, - utc-delta : (instant) -> (duration,string), - utc-inverse: (instant) -> maybe = fn(i) { Nothing } -) +abstract struct timezone + pub name : string + utc-delta : (instant) -> (duration,string) + utc-inverse : (instant) -> maybe = fn(i) { Nothing } + // Same timezone? pub fun (==)( tz1 : timezone, tz2 : timezone ) : bool diff --git a/lib/std/time/chrono-inline.c b/lib/std/time/chrono-inline.c index 7deb61861..89ab381aa 100644 --- a/lib/std/time/chrono-inline.c +++ b/lib/std/time/chrono-inline.c @@ -7,10 +7,11 @@ ---------------------------------------------------------------------------*/ static kk_std_core_types__tuple2_ kk_time_unix_now_tuple(kk_context_t* ctx) { - int64_t asecs; - int64_t isecs = kk_time_unix_now(&asecs,ctx); - double frac = (double)asecs * 1e-18; - double secs = (double)isecs; + kk_duration_t d = kk_time_unix_now(ctx); + // the conversion has about 15 digits of precision + // we cannot do this more precisely as the api expects the fraction between 0.0 and 2.0 (for leap seconds). + double secs = (double)d.seconds; + double frac = (double)d.attoseconds * 1e-18; return kk_std_core_types__new_dash__lp__comma__rp_( kk_double_box(secs,ctx), kk_double_box(frac,ctx), ctx ); } diff --git a/lib/std/time/chrono.kk b/lib/std/time/chrono.kk index 05b353ece..8c97a5652 100644 --- a/lib/std/time/chrono.kk +++ b/lib/std/time/chrono.kk @@ -11,6 +11,7 @@ */ module std/time/chrono +import std/time/timestamp import std/time/duration import std/time/instant import std/time/utc @@ -52,7 +53,8 @@ pub fun now() : instant pub fun now-in( ts : timescale = ts-ti) : ndet instant // on current backends (C#, JavaScript) we can only use `unix-now` :-( val (secs,frac) = unix-now() - unix-instant(secs,frac,ts) + val leap = 0 + unix-instant(timespan(secs,frac),leap,ts) // Returns a unix time stamp as seconds and fraction of seconds; // The fraction of seconds is for added precision if necessary, diff --git a/lib/std/time/date.kk b/lib/std/time/date.kk index 677174e81..6a952298d 100644 --- a/lib/std/time/date.kk +++ b/lib/std/time/date.kk @@ -21,11 +21,11 @@ import std/num/ddouble ----------------------------------------------------------------------------*/ // A date consists of a the year, month, and day. -pub struct date( - year : int, - month: int, +pub value struct date + year : int + month: int day : int -) + // Create an ISO weekdate where the "month" is the ISO week number. pub fun weekdate( year : int, month: int, weekday : weekday ) : date @@ -69,11 +69,11 @@ pub fun (+)( d1 : date, d2 : date ) : date ----------------------------------------------------------------------------*/ // A clock consists of the hour, minute, second, and fractional second (between ``0.0` and `1.0`). -pub struct clock( - hours : int, - minutes : int, +pub struct clock + hours : int + minutes : int seconds : ddouble -) + // Create a clock from a `:duration`; normalizes the clock with seconds and minutes under 60. //pub fun clock( d : duration ) : clock diff --git a/lib/std/time/duration.kk b/lib/std/time/duration.kk index d45b579e0..746062417 100644 --- a/lib/std/time/duration.kk +++ b/lib/std/time/duration.kk @@ -21,9 +21,9 @@ import std/time/timestamp // A duration in time in (TAI) SI seconds (as measured on the earth's geoid).\ // A duration is represented by a `:ddouble` giving it a high range and precision (see the [`instant`](std_time_instant.html) module) -abstract struct duration( +abstract value struct duration secs : timespan -) + // A zero duration. pub val zero : duration = Duration(timespan0) @@ -50,6 +50,10 @@ pub fun duration( secs : int, frac : float64 = 0.0 ) : duration pub fun duration( secs : float64 ) : duration Duration(timespan(secs)) +// Create a duration from seconds and a fraction as a `:float64`'s. +pub fun duration( secs : float64, frac : float64 ) : duration + Duration(timespan(secs,frac)) + // Convert a duration to a `:timespan`. pub fun timespan( d : duration ) : timespan d.seconds diff --git a/lib/std/time/instant.kk b/lib/std/time/instant.kk index 681a21ee1..72f0a5926 100644 --- a/lib/std/time/instant.kk +++ b/lib/std/time/instant.kk @@ -127,7 +127,7 @@ efficiency and precision. They automatically convert between different time scal when necessary (for example when comparing instants in time, or calculating durations between UTC calendar times). */ -abstract struct instant +abstract value struct instant since : timestamp // time since the 2000-01-01 in the timescale ts : timescale // the time scale (TAI, UTC, etc) diff --git a/lib/std/time/timer-inline.c b/lib/std/time/timer-inline.c index c9bc96ba9..1481fb9a9 100644 --- a/lib/std/time/timer-inline.c +++ b/lib/std/time/timer-inline.c @@ -7,10 +7,11 @@ ---------------------------------------------------------------------------*/ static kk_std_core_types__tuple2_ kk_timer_ticks_tuple(kk_context_t* ctx) { - int64_t asecs; - int64_t isecs = kk_timer_ticks(&asecs,ctx); - double frac = (double)asecs * 1e-18; - double secs = (double)isecs; + kk_duration_t d = kk_timer_ticks(ctx); + // the conversion has about 15 digits of precision + // we cannot do this more precisely as the api expects the fraction between 0.0 and 2.0 (for leap seconds). + double secs = (double)d.seconds; + double frac = (double)d.attoseconds * 1e-18; return kk_std_core_types__new_dash__lp__comma__rp_( kk_double_box(secs,ctx), kk_double_box(frac,ctx), ctx ); } diff --git a/lib/std/time/timer.kk b/lib/std/time/timer.kk index e812cf988..7ce93a2ca 100644 --- a/lib/std/time/timer.kk +++ b/lib/std/time/timer.kk @@ -29,7 +29,7 @@ extern import // and have at least millisecond resolution. pub fun ticks() : ndet duration val (secs,frac) = xticks() - duration(secs.truncate.int, secs.fraction + frac) + duration(secs,frac) extern xticks() : ndet (float64,float64) c "kk_timer_ticks_tuple" diff --git a/lib/std/time/timestamp.kk b/lib/std/time/timestamp.kk index 0512422f5..8389a5e3a 100644 --- a/lib/std/time/timestamp.kk +++ b/lib/std/time/timestamp.kk @@ -32,6 +32,9 @@ pub fun timespan( seconds : int, frac : float64 = 0.0 ) : timespan pub fun timespan( secs : float64 ) : timespan ddouble(secs) +pub fun timespan( secs : float64, frac : float64 ) : timespan + ddouble(secs,frac) + // Timespan from a `:ddouble`. Just for convenience as `:timespan` is an alias pub fun timespan( secs : ddouble ) : timespan secs diff --git a/lib/std/time/utc.kk b/lib/std/time/utc.kk index 3b41e282d..9b1439ce9 100644 --- a/lib/std/time/utc.kk +++ b/lib/std/time/utc.kk @@ -339,14 +339,14 @@ To indicate a time in a leap second, you can use a fraction `frac` that is large This works well for systems that support [``CLOCK_UTC``](http://www.madore.org/~david/computers/unix-leap-seconds.html). */ pub fun unix-instant( u : float64, frac : float64 = 0.0, ts : timescale = ts-ti ) : instant - val t = u.ddouble + frac.fraction.ddouble + val t = timespan(u,frac.fraction) val leap = frac.truncate.int unix-instant(t,leap,ts) // Create an instant from raw unix seconds since the unix epoch (1970-01-01T00:00:10 TAI) // Use a fraction `> 1` to indicate a time inside a leap second. pub fun unix-instant( u : int, frac : float64 = 0.0, ts : timescale = ts-ti ) : instant - val t = u.ddouble + frac.fraction.ddouble + val t = timespan(u.ddouble + frac.fraction.ddouble) val leap = frac.truncate.int unix-instant(t,leap,ts) @@ -491,14 +491,14 @@ to +33. This looks like: UTC-to-TAI-delta: ... +32 | +33 ... UTC timestamp 189388799 189388799+1 189388800 -UTC 2015-12-31T23:59: 59 60 leap 00 +UTC 2005-12-31T23:59: 59 60 leap 00 ---------|-----------|xxxxxxxxxxxx|------------- | | | -TAI 2016-01-01T00:00: 31 32 33 +TAI 2006-01-01T00:00: 31 32 33 TAI timestamp: 189388831 189388832 189388833 In the code below, suppose `tai` is `189388832.5`. -The we estimate at first the delta `dtai0` to +33, so our +Then we estimate at first the delta `dtai0` to +33, so our estimate `utc0` is `189388799.5` (just before the leap step!). We then use `utc0` to get delta-TAI at that time, +32 and set the difference `diff` to `(33-32) == 1` -- the time of the diff --git a/package.yaml b/package.yaml index b236e52f2..59440a067 100644 --- a/package.yaml +++ b/package.yaml @@ -6,7 +6,7 @@ # - util/minbuild name: koka -version: 2.4.0 +version: 2.4.2 github: "koka-lang/koka" license: Apache-2.0 author: Daan Leijen @@ -53,7 +53,7 @@ executables: cpp-options: - -DKOKA_MAIN="koka" - -DKOKA_VARIANT="release" - - -DKOKA_VERSION="2.4.0" + - -DKOKA_VERSION="2.4.2" - -DREADLINE=0 # 1:getline, 2:readline, 3:haskeline, or 0:isocline when: - condition: os(windows) @@ -76,6 +76,6 @@ tests: - hspec - hspec-core - process - - regex-compat-tdfa + - regex-compat >= 0.95.2.1 - json diff --git a/readme.md b/readme.md index 6b518731d..86bf53973 100644 --- a/readme.md +++ b/readme.md @@ -15,7 +15,7 @@ # Koka: a Functional Language with Effects _Koka v2 is a research language that currently under heavy development with the new C backend_ -_Latest release_: v2.4.0, 2022-02-07 ([Install]). +_Latest release_: v2.4.2, 2023-07-03 ([Install]). @@ -85,6 +85,9 @@ and all previous interns working on earlier versions of Koka: Daniel Hillerströ ## Recent Releases +* `v2.4.2`, 2023-07-03: interim release with support for the new `fip` and `fbip` keywords + to support fully-in-place programming [[11](#references)]. Various bug fixes and performance + enhancements. * `v2.4.0`, 2022-02-07: automatic generation of installation packages for various Linux distributions (by [Rubikscraft](https://github.com/rubikscraft)), improved specialization and integer add/sub, add `rbtree-fbip` sample, improve grammar (`pub` (instead of `public`, remove private (as it is always default)), @@ -127,7 +130,7 @@ and all previous interns working on earlier versions of Koka: Daniel Hillerströ # Install -Koka has [binary installers][install] for Windows (x64), macOS (x64, M1), Linux (x64, arm64), and FreeBSD (x64). +Koka has [binary installers][install] for Windows (x64), macOS (x64, M1), and Linux (x64) For other platforms, you need to build the compiler from source. # Build from Source @@ -137,9 +140,8 @@ without problems on most common platforms, e.g. Windows (including WSL), macOS, Unix. The following programs are required to build Koka: * [Stack](https://docs.haskellstack.org/) to run the Haskell compiler. - Use `curl -sSL https://get.haskellstack.org/ | sh` - on Unix and macOS x64, or the binary [installer](https://get.haskellstack.org/stable/windows-x86_64-installer.exe) on Windows. - On macOS M1, use `brew install haskell-stack --head` (and see the [build notes](#build-notes) below). + Use `brew install haskell-stack` on macOS, `curl -sSL https://get.haskellstack.org/ | sh` on Unix, + or the binary [installer](https://get.haskellstack.org/stable/windows-x86_64-installer.exe) on Windows. * Optional: [vcpkg] to be able to link easily with C libraries. Use `brew install vcpkg` on macOS. On other systems use the vcpkg [install][vcpkg] instructions (Koka can find vcpkg automatically if installed to `~/vcpkg`). @@ -160,7 +162,7 @@ $ stack exec koka You can also use `stack build --fast` to build a debug version of the compiler. Use `stack test --fast` to run the test-suite. -(See the [build notes](#build-notes) below for building macOS M1, or if you have issues when running- or installing `stack`). +(See the [build notes](#build-notes) below if you have issues when running- or installing `stack`). ## Create an Install Bundle @@ -278,8 +280,6 @@ More advanced projects: needs work on packaging it to make it easy to build and install as part of the Koka installer. * [ ] Package management of Koka modules. * [x] Compile to WASM (using emscripten on the current C backend) -* [ ] Extend TRMC to include (1) return results with pairs (like `unzip` or `partition`), (2) associative functions - (like `+` in `length`), and (3) mutually recursive functions. * [ ] Improve compilation of local state to use local variables directly (in C) without allocation. Tricky though due to multiple resumptions. * [ ] Improve performance of array/mutable reference programming. Koka is has great performance for algebraic datatypes but lags when using more imperative array algorithms. This requires better @@ -295,7 +295,7 @@ More advanced projects: Master/PhD level: -* [ ] Better language level FBIP support with guaranteed datatype matching, automatic derivative and visitor generation. +* [x] Better language level FBIP support with guaranteed datatype matching, automatic derivative and visitor generation. * [ ] Can we use C++ exceptions to implement "zero-cost" `if yielding() ...` branches and remove the need join points (see [9]). * [x] Float up `open` calls to improve effect handling (worked on by Naoya Furudono) * [x] Formalize opening and closing effect row types (worked on by Kazuki Ikemori) @@ -329,9 +329,8 @@ The main development branches are: ## Building on macOS M1 -Currently (Dec 2021) you need to use `brew install haskell-stack --head` -to get the latest `2.7.4` version of stack. (Have patience as the cabal -install step takes about 20 min). Moreover, you need to add the `brew` +You need at least `stack` version >= 2.11 +Furthermore, you may need to add the `brew` installed LLVM to your path afterwards, or otherwise stack cannot find the LLVM tools. Add the following to your `~/.zshrc` script and open an fresh prompt: @@ -507,4 +506,8 @@ Also as MSR-TR-2021-5, Mar, 2021. [pdf](https://www.microsoft.com/en-us/research/publication/generalized-evidence-passing-for-effect-handlers/) 10. Anton Lorenzen and Daan Leijen. “ Reference Counting with Frame-Limited Reuse” Microsoft Research -technical report MSR-TR-2021-30, Nov 2021. [pdf](https://www.microsoft.com/en-us/research/publication/reference-counting-with-frame-limited-reuse-extended-version/) +technical report MSR-TR-2021-30, Nov 2021, (updated Mar 2022, v2). [pdf](https://www.microsoft.com/en-us/research/publication/reference-counting-with-frame-limited-reuse-extended-version/) + +11. Anton Lorenzen, Daan Leijen, and Wouter Swierstra. “ FP2: Fully in-Place Functional Programming” +The 28th ACM SIGPLAN International Conference on Functional Programming (ICFP), September 2023. +[pdf](https://www.microsoft.com/en-us/research/uploads/prod/2023/05/fbip.pdf) (extended tech. report MSR-TR-2023-19, May 2023). diff --git a/samples/basic/garsia-wachs.kk b/samples/basic/garsia-wachs.kk index 791014b31..72aa0ffdc 100644 --- a/samples/basic/garsia-wachs.kk +++ b/samples/basic/garsia-wachs.kk @@ -25,7 +25,7 @@ fun show( t : tree ) : string //---------------------------------------------------- // Non empty lists //---------------------------------------------------- -pub type list1 +pub value type list1 Cons1( head : a, tail : list ) diff --git a/samples/handlers/nim.kk b/samples/handlers/nim.kk index 59ea7d475..363a6b2fe 100644 --- a/samples/handlers/nim.kk +++ b/samples/handlers/nim.kk @@ -1,5 +1,6 @@ /* Examples from the paper "Liberating effects with rows and handlers" by Daniel Hillerström and Sam Lindley. + */ module nim diff --git a/samples/handlers/scoped.kk b/samples/handlers/scoped.kk index e5df71d07..349cb9f23 100644 --- a/samples/handlers/scoped.kk +++ b/samples/handlers/scoped.kk @@ -1,5 +1,6 @@ /* Examples from the paper "Effect handlers in Scope" by Nicolas Wu, Tom Schrijvers, and Ralf Hinze + */ effect nondet diff --git a/samples/handlers/unix.kk b/samples/handlers/unix.kk new file mode 100644 index 000000000..d840e6e58 --- /dev/null +++ b/samples/handlers/unix.kk @@ -0,0 +1,219 @@ +// Based on Daniel Hillerström's PhD Thesis, +// "Foundations for Programming and Implementing Effect Handlers" (chap. 2) +// +// which shows how to build an OS API as a composition of (orthogonal) effect handlers. +// +// The terminology and design is based on: +// "The UNIX Time- Sharing System" by Dennis M. Ritchie and Ken Thompson +// https://dsf.berkeley.edu/cs262/unix.pdf + + +// ----------------------------------------- +// Basic I/O +// Shows output state (writer monad) + +effect bio // basic I/O + fun write( fd : filedesc, s : string ) : () + +alias filedesc = int + +val stdout = 0 + +fun echo( s : string ) : bio () + write(stdout,s) + +fun bio( action : () -> a ) : e (a,string) + var buf := "" + with return(x) (x,buf) + with fun write(fd,s) buf := buf ++ s + action() + +fun example1() + with bio + echo("hi ") + echo("unix world") + + +// ----------------------------------------- +// Exit +// Show non-linear control by exiting a computation. (exception monad) + +effect exit + ctl exit( exitcode : int ) : a + +fun status( action : () -> a ) : e int + with ctl exit(code) code + action() + 0 + +fun example2() : (int,string) + with bio + with status + echo("hi ") + exit(1) + echo("unix world") + + +// ----------------------------------------- +// User environment +// Show dynamic binding (reader monad) + +type user + Root + Alice + Bob + +fun show( user : user ) : string + match user + Root -> "root" + Alice -> "alice" + Bob -> "bob" + +effect whoami + fun whoami() : string + + + +fun env( user : user, action : () -> a ) : e a + with fun whoami() show(user) + action() + +fun example3() + with bio + with status + with env(Alice) + echo("hi ") + echo(whoami()) + + +fun show( (_,s) : ((),string) ) : string + show(s) + +fun show( (i,s) : (int,string) ) : string + "exit with status " ++ i.show ++ "\n" ++ show(s) + + +// ----------------------------------------- +// Session management +// su: substitute user + +effect su + ctl su( u : user ) : () + +fun session-manager1( initial-user : user, action : () -> a ) : e a + with env(initial-user) + with ctl su( u : user ) + mask + with env(u) + resume(()) + action() + +fun session-manager2( initial-user : user, action : () -> a ) : e a + with fun whoami() show(initial-user) + with ctl su( u : user ) + with override fun whoami() show(u) + resume(()) + action() + +fun session-manager3( initial-user : user, action : () -> a ) : e a + var user := initial-user + with fun whoami() show(user) + with fun su(u) user := u + action() + + +fun example4() + with bio + with status + with session-manager3(Root) + echo("hi ") + echo(whoami()) + su(Alice) + echo(", and hi ") + echo(whoami()) + + +// ----------------------------------------- +// Multitasking +// + +effect fork + ctl fork() : bool // true if this is the parent + + +fun forking( action : () -> a ) : e list + with handler + return(x) [x] + ctl fork() resume(True) ++ resume(False) + action() + + +type pstate + Done(result : a) + Paused(resumption : () -> e pstate ) + +effect interrupt + ctl interrupt() : () + +fun reify-process( action : () -> a ) : e pstate + with raw ctl interrupt() Paused( fn() rcontext.resume(()) ) + Done(action()) + +fun scheduler( pstates : list,a>> ) : list + fun schedule( todos : list,a>>, dones : list ) : list + match todos + Nil -> dones + Cons(Done(x),pp) -> schedule(pp, Cons(x,dones)) + Cons(Paused(p),pp) -> + val ps = forking( p ) + schedule( pp ++ ps, dones ) + schedule(pstates,[]) + +fun timeshare( action : () -> a ) : list + val p = Paused( fn() reify-process(action) ) + scheduler([p]) + + +fun ritchie() : () + echo("UNIX is basically ") + echo("a simple operating system, ") + echo("but ") + echo("you have to be a genius to understand the simplicity.\n") + +fun hamlet() : () + echo("To be, or not to be, ") + echo("that is the question:\n") + echo("Whether 'tis nobler in the mind to suffer\n") + +fun example5() + with return(x:(list,string)) x.snd.println + with bio + with timeshare + with status + with session-manager3(Root) + if fork() then + su(Alice) + ritchie() + else + su(Bob) + hamlet() + + +fun interrupt-write( action : () -> a ) : a + with override fun write(fd,s) { interrupt(); write(fd,s) } + action() + +fun example6() + with return(x:(list,string)) x.snd.println + with bio + with timeshare + with interrupt-write + with status + with session-manager3(Root) + if fork() then + su(Alice) + ritchie() + else + su(Bob) + hamlet() + diff --git a/samples/named-handlers/unify.kk b/samples/named-handlers/unify.kk new file mode 100644 index 000000000..e76de4a6e --- /dev/null +++ b/samples/named-handlers/unify.kk @@ -0,0 +1,114 @@ +/* Shows the use of named effect handlers under an umbrella effect. + + For more info see the paper: + "First-class named effect handlers", Daan Leijen, Ningning Xie, and Youyou Cong, 2020. +*/ +module unify + +// A unifiable type +type utype + UVar( v : variable ) + UCon( tag : string ) + UApp( t1 : utype, t2 : utype ) + +// A non-unifiable type +type ntype + Con( tag : string ) + App( t1 : ntype, t2 : ntype ) + + +// Umbrella substitution effect +scoped effect subst + ctl fresh() : variable + + +// Unification variables under a substitution +named effect variable in subst // named under umbrella effect `:subst` + fun get() : maybe> // `:(variable) -> ,pure> maybe>` + fun resolve( tp : utype ) : () // `:(variable,utype) -> ,pure> ()` + + +// private (named) handler instance for creating a unification variable +fun with-var(action) + var mtp := Nothing + with v <- named handler + fun get() mtp + fun resolve(tp) + match mtp + Nothing -> + // if occurs(v,tp) then throw("recursive type") + mtp := Just(tp) + Just -> throw("cannot resolve a unification variable more than once") + action(v) + + +// umbrella handler for substitution +fun subst(action : forall () -> ,pure|e> a) : a // required rank-2 signature + with ctl fresh() with-var(resume) + action() + + +// resolve all unification variables to a non-unifiable type +fun resolve-all( tp : utype ) : ,pure> ntype + match tp + UCon(tag) -> Con(tag) + UApp(tp1,tp2) -> App( resolve-all(tp1), resolve-all(tp2) ) + UVar(v) -> + match get(v) + Nothing -> throw( "unresolved variable" ) + Just(tpv) -> resolve-all(tpv) + + +// Unify two types under a substitution handler +fun unify( tp1 : utype, tp2 : utype ) : ,div,exn> utype + match (tp1,tp2) + (UCon(tag1), UCon(tag2)) | tag1 == tag2 -> tp1 + // (UVar(v1), UVar(v2)) | v1 == v2 -> tp1 + (UApp(tp11,tp12),UApp(tp21,tp22)) -> UApp( unify(tp11,tp21), unify(tp12,tp22) ) + (UVar(v1),_) -> match get(v1) + Nothing -> + resolve(v1,tp2) + tp2 + Just(tpv1) -> match tp2 + UVar(v2) -> match get(v2) + Nothing -> + resolve(v2,tpv1) + tpv1 + Just(tpv2) + -> unify(tpv1,tpv2) + _ -> unify(tpv1,tp2) + _ -> throw("cannot unify types") + + +// Helpers to create types +fun inttp() : utype + UCon("int") + +fun list( tp1 : utype ) : utype + UApp( UCon("list"), tp1 ) + +fun to( tp1 : utype, tp2 : utype ) : utype + UApp( UApp( UCon("->"), tp1 ), tp2 ) + +pub fun show( tp : ntype, top : bool = True ) : string + fun parens(s) + if top then s else ("(" ++ s ++ ")" ) + match tp + App(App(Con("->"),t1),t2) -> (t1.show ++ " -> " ++ t2.show).parens + Con(tag) -> tag + App(t1,t2) -> (t1.show ++ " " ++ t2.show(False)).parens + + +// Test unification +pub fun test() + with subst + val a = fresh() + val b = fresh() + val tp1 = to( UVar(a), UVar(a) ) + val tp2 = to( UVar(b), list(inttp()) ) + unify(tp1,tp2).resolve-all + +pub fun main() + val tp = test() + println( "unified type: " ++ tp.show ) + diff --git a/src/Backend/C/Box.hs b/src/Backend/C/Box.hs index d35a32e5f..be945bcbd 100644 --- a/src/Backend/C/Box.hs +++ b/src/Backend/C/Box.hs @@ -157,7 +157,7 @@ boxPattern fromTp pat | cType (fromTp) /= cType toTp PatCon{} -> patTypeRes pat PatVar tname _ -> typeOf tname PatLit lit -> typeOf lit - PatWild -> typeAny -- cannot happen + -- PatWild -> typeAny -- cannot happen isComplexCoerce coerce = case (cType fromTp, cType toTp) of @@ -390,12 +390,15 @@ patBox tpPat tpRes pat = PatCon (TName nameBoxCon (conInfoType boxConInfo)) [pat] boxConRepr [tpPat] [] tpRes boxConInfo True boxConRepr :: ConRepr -boxConRepr = ConSingle nameTpBox (DataSingle False) 0 +boxConRepr = ConSingle nameTpBox (DataSingle False) (valueReprScan 1) CtxNone 0 boxConInfo :: ConInfo boxConInfo = ConInfo nameBox nameTpBox [a] [] [(nameNil,TVar a)] tp - Inductive rangeNull [] [Public] True Public "" + Inductive rangeNull [] [Public] True + [(nameNil,TVar a)] + (valueReprScan 1) {- size is wrong with knowing the platform ? -} + Public "" where tp = TForall [a] [] (TFun [(nameNil,TVar a)] typeTotal typeBoxStar) a = TypeVar (0) kindStar Bound diff --git a/src/Backend/C/FromCore.hs b/src/Backend/C/FromCore.hs index 82f6d1d2f..c283d5175 100644 --- a/src/Backend/C/FromCore.hs +++ b/src/Backend/C/FromCore.hs @@ -22,6 +22,7 @@ import qualified Data.Set as S import Common.File( normalizeWith, startsWith, endsWith ) import Kind.Kind import Kind.Newtypes +import Kind.Repr( orderConFields ) import Type.Type import Type.TypeVar import Type.Kind( getKind ) @@ -42,9 +43,9 @@ import Core.Pretty import Core.CoreVar import Core.Borrowed ( Borrowed, borrowedExtendICore ) -import Backend.C.Parc -import Backend.C.ParcReuse -import Backend.C.ParcReuseSpec +import Backend.C.Parc( parcCore ) +import Backend.C.ParcReuse ( parcReuseCore ) +import Backend.C.ParcReuseSpec (parcReuseSpecialize ) import Backend.C.Box type CommentDoc = Doc @@ -66,9 +67,9 @@ externalNames -- Generate C code from System-F core language -------------------------------------------------------------------------- -cFromCore :: CTarget -> BuildType -> FilePath -> Pretty.Env -> Platform -> Newtypes -> Borrowed -> Int -> Bool -> Bool -> Bool -> Bool -> Int -> Maybe (Name,Bool) -> Core -> (Doc,Doc,Core) -cFromCore ctarget buildType sourceDir penv0 platform newtypes borrowed uniq enableReuse enableSpecialize enableReuseSpecialize enableBorrowInference stackSize mbMain core - = case runAsm uniq (Env moduleName moduleName False penv externalNames newtypes platform False) +cFromCore :: CTarget -> BuildType -> FilePath -> Pretty.Env -> Platform -> Newtypes -> Borrowed -> Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Maybe (Name,Bool) -> Core -> (Doc,Doc,Core) +cFromCore ctarget buildType sourceDir penv0 platform newtypes borrowed uniq enableReuse enableSpecialize enableReuseSpecialize enableBorrowInference eagerPatBind stackSize mbMain core + = case runAsm uniq (Env moduleName moduleName False penv externalNames newtypes platform eagerPatBind) (genModule ctarget buildType sourceDir penv platform newtypes borrowed enableReuse enableSpecialize enableReuseSpecialize enableBorrowInference stackSize mbMain core) of (bcore,cdoc,hdoc) -> (cdoc,hdoc,bcore) where @@ -356,13 +357,7 @@ genTopDefDecl genSig inlineC def@(Def name tp defBody vis sort inl rng comm) genFunDef tnames app -- special case string literals Lit (LitString s) - -> do let (cstr,clen) = cstring s - decl = if (isPublic vis) then empty else text "static" - if (clen > 0) - then emitToC (text "kk_define_string_literal" <.> tupled [decl,ppName name,pretty clen,cstr] {- <.> semi -}) - else emitToC (text "kk_define_string_literal_empty" <.> tupled [decl, ppName name]) - when (isPublic vis) $ - emitToH (linebreak <.> text "extern" <+> ppType typeString <+> ppName name <.> semi) + -> do genTopLevelStringLiteral name vis s -- special case for doubles Lit lit@(LitFloat f) -> do let flt = ppLit lit @@ -391,8 +386,8 @@ genTopDefDecl genSig inlineC def@(Def name tp defBody vis sort inl rng comm) genFunDef params body = do let args = map ( ppName . getName ) params isTailCall = body `isTailCalling` name - bodyDoc <- (if isTailCall then withStatement else id) - (genStat (ResultReturn (Just (TName name resTp)) params) body) + bodyDoc <- -- (if isTailCall then withStatement else id) + genStat (ResultReturn (Just (TName name resTp)) params) body penv <- getPrettyEnv let tpDoc = typeComment (Pretty.ppType penv tp) let sig = genLamSig inlineC vis name params body @@ -411,6 +406,18 @@ unitSemi :: Type -> Doc unitSemi tp = if (isTypeUnit tp) then text " = kk_Unit;" else semi +genTopLevelStringLiteral :: Name -> Visibility -> String -> Asm () +genTopLevelStringLiteral name vis s + = do let (cstr,clen) = cstring s + decl = if (isPublic vis) then empty else text "static" + if (clen > 0) + then do emitToC (text "kk_declare_string_literal" <.> tupled [decl,ppName name,pretty clen,cstr] {- <.> semi -}) + emitToInit (text "kk_init_string_literal" <.> arguments [ppName name]) + -- todo: emit drop in Done? + else emitToC (text "kk_define_string_literal_empty" <.> tupled [decl, ppName name]) + when (isPublic vis) $ + emitToH (linebreak <.> text "extern" <+> ppType typeString <+> ppName name <.> semi) + --------------------------------------------------------------------------------- -- Generate value constructors for each defined type --------------------------------------------------------------------------------- @@ -438,9 +445,12 @@ genTypeDefPre (Data info isExtend) -- generate the type declaration if (dataRepr == DataEnum) then let enumIntTp = case (dataInfoDef info) of - DataDefValue 1 0 -> "uint8_t" - DataDefValue 2 0 -> "uint16_t" - _ -> "uint32_t" + DataDefValue (ValueRepr n 0 _) + -> if (n <= 1) then "uint8_t" + else if (n <= 2) then "uint16_t" + else if (n <= 4) then "uint32_t" + else "uint64_t" + _ -> "kk_intb_t" -- should not happen? ppEnumCon (con,conRepr) = ppName (conInfoName con) -- <+> text "= datatype_enum(" <.> pretty (conTag conRepr) <.> text ")" in emitToH $ ppVis (dataInfoVis info) <.> text "enum" <+> ppName (typeClassName (dataInfoName info)) <.> text "_e" <+> @@ -456,8 +466,8 @@ genTypeDefPre (Data info isExtend) <-> (if dataReprMayHaveSingletons dataRepr then (text "typedef kk_datatype_t" <+> ppName (typeClassName name) <.> semi) - else (text "typedef struct" <+> ppName (typeClassName name) <.> text "_s*" <+> ppName (typeClassName name) <.> semi)) - + else ( -- text "typedef struct" <+> ppName (typeClassName name) <.> text "_s*" <+> ppName (typeClassName name) <.> semi)) + text "typedef kk_datatype_ptr_t" <+> ppName (typeClassName name) <.> semi)) genTypeDefPost:: TypeDef -> Asm () genTypeDefPost (Synonym synInfo) @@ -472,10 +482,15 @@ genTypeDefPost (Data info isExtend) -- order fields of constructors to have their scan fields first let conInfoReprs = zip (dataInfoConstrs info) conReprs conInfos <- mapM (\(conInfo,conRepr) -> do -- should never fail as mixed raw/scan is checked in kindInfer + {- newtypes <- getNewtypes platform <- getPlatform let (fields,size,scanCount) = orderConFieldsEx platform newtypes (dataRepr == DataOpen) (conInfoParams conInfo) + -} + let fields = conInfoOrderedParams conInfo + scanCount = valueReprScanCount (conInfoValueRepr conInfo) return (conInfo,conRepr,fields,scanCount)) conInfoReprs + let maxScanCount = maxScanCountOf conInfos minScanCount = minScanCountOf conInfos @@ -492,15 +507,15 @@ genTypeDefPost (Data info isExtend) return () else if (dataRepr == DataEnum || not (dataReprIsValue dataRepr)) then return () - else emitToH $ if (hasTagField dataRepr) + else emitToH $ if (needsTagField dataRepr) then ppVis (dataInfoVis info) <.> text "struct" <+> ppName name <.> text "_s" <+> block (text "kk_value_tag_t _tag;" <-> text "union" <+> block (vcat ( map ppStructConField (dataInfoConstrs info) - ++ (if (maxScanCount > 0 && minScanCount /= maxScanCount) - then [text "kk_box_t _fields[" <.> pretty maxScanCount <.> text "];"] + ++ (if (maxScanCount > 1 && minScanCount /= maxScanCount) + then [text "kk_box_t _fields[" <.> pretty (maxScanCount - 1) <.> text "];"] -- -1 as it includes the tag field itself else []) - )) <+> text "_cons;") <.> semi + )) <+> text "_cons;") <.> semi -- <-> text "kk_struct_packed_end" <-> ppVis (dataInfoVis info) <.> text "typedef struct" <+> ppName name <.> text "_s" <+> ppName (typeClassName name) <.> semi else ppVis (dataInfoVis info) <.> text "typedef struct" <+> (case (dataRepr,dataInfoConstrs info) of @@ -540,10 +555,10 @@ genConstructorType info dataRepr (con,conRepr,conFields,scanCount) = -> return () -- represented as an enum -- _ | null conFields && (dataRepr < DataNormal && not (isDataStructLike dataRepr)) -- -> return () - _ -> do emitToH $ ppVis (conInfoVis con) <.> text "struct" <+> ppName ((conInfoName con)) <+> + _ -> do emitToH $ ppVis (conInfoVis con) <.> text "struct" <+> ppName ((conInfoName con)) <+> block (let fields = (typeField ++ map ppConField conFields) in if (null fields) then text "kk_box_t _unused;" -- avoid empty struct - else vcat fields) <.> semi + else vcat fields) <.> semi -- <-> text "kk_struct_packed_end" where typeField = if (dataReprIsValue dataRepr) then [] else [text "struct" <+> ppName (typeClassName (dataInfoName info)) <.> text "_s" <+> text "_base;"] @@ -564,11 +579,11 @@ genConstructorTest info dataRepr (con,conRepr,conFields,scanCount) genConstructorTestX :: DataInfo -> DataRepr -> ConInfo -> ConRepr -> Asm () genConstructorTestX info dataRepr con conRepr - = do emitToH $ text "static inline bool" <+> (conTestName con) <.> tupled [ppName (typeClassName (dataInfoName info)) <+> text "x"] + = do emitToH $ text "static inline bool" <+> (conTestName con) <.> parameters [ppName (typeClassName (dataInfoName info)) <+> text "x"] <+> block( text "return (" <.> ( let nameDoc = ppName (conInfoName con) -- tagDoc = text "datatype_enum(" <.> pretty (conTag conRepr) <.> text ")" - dataTypeTagDoc = text "kk_datatype_tag" <.> tupled [text "x"] + dataTypeTagDoc = text "kk_datatype_tag" <.> arguments [text "x"] valueTagEq = text "kk_value_tag_eq(x._tag," <+> ppConTag con conRepr dataRepr <.> text ")" in case conRepr of ConEnum{} -> text "x ==" <+> ppConTag con conRepr dataRepr @@ -579,19 +594,23 @@ genConstructorTestX info dataRepr con conRepr ConSingle{} -> text "true" ConStruct{} -> valueTagEq ConAsJust{conAsNothing=nothing} - -> text "!" <.> conTestNameX nothing <.> tupled [text "x"] + -> text "!" <.> conTestNameX nothing <.> arguments [text "x"] ConAsCons{conAsNil=nil} -> -- todo: is_ptr may be faster on arm64? -- text "kk_datatype_is_ptr(x)" - text "!" <.> conTestNameX nil <.> tupled [text "x"] + text "!" <.> conTestNameX nil <.> arguments [text "x"] ConNormal{} -- | dataRepr == DataSingleNormal -> text "datatype_is_ptr(x)" -- | otherwise -> text "datatype_is_ptr(x) && datatype_tag_fast(x) ==" <+> ppConTag con conRepr dataRepr -- -> text "datatype_tag(x) ==" <+> ppConTag con conRepr dataRepr -> text (if (dataReprMayHaveSingletons dataRepr) - then "kk_datatype_has_ptr_tag" else "kk_basetype_has_tag") - <.> tupled [text "x", ppConTag con conRepr dataRepr] - ConOpen{} -> text "kk_string_ptr_eq_borrow" <.> tupled [text "x->_tag",ppConTag con conRepr dataRepr] + then "kk_datatype_has_ptr_tag" else "kk_datatype_ptr_has_tag") + <.> arguments [text "x", ppConTag con conRepr dataRepr] + ConOpen{} -> let opentag = parens ( + text "kk_datatype_as" <.> arguments [ + text "struct" <+> ppName (typeClassName (dataInfoName info)) <.> text "_s*", text "x"] + ) <.> text "->_tag" + in text "kk_string_ptr_eq_borrow" <.> tupled [opentag,ppConTag con conRepr dataRepr] ) <.> text ");") conTestName con @@ -609,12 +628,12 @@ ppConTag con conRepr dataRepr ConSingleton{} | dataRepr == DataAsMaybe -> text "KK_TAG_NOTHING" ConAsJust{} -> text "KK_TAG_JUST" -- ConSingleton{} | dataRepr == DataAsList -> text "datatype_from_enum(" <.> pretty (conTag conRepr) <.> text ")" -- ppName ((conInfoName con)) - _ | hasTagField dataRepr -> text "kk_value_tag(" <.> pretty (conTag conRepr) <.> text ")" + _ | needsTagField dataRepr -> text "kk_value_tag(" <.> pretty (conTag conRepr) <.> text ")" _ -> text "(kk_tag_t)" <.> parens (pretty (conTag conRepr)) genConstructorCreate :: DataInfo -> DataRepr -> ConInfo -> ConRepr -> [(Name,Type)] -> Int -> Int -> Asm () -genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount +genConstructorCreate info dataRepr con conRepr allFields scanCount maxScanCount = do {- if (null conFields && not (dataReprIsValue dataRepr)) then do let structTp = text "struct" <+> ppName (typeClassName (dataInfoName info)) <.> text "_s" @@ -631,9 +650,13 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount -} when (dataRepr == DataOpen) $ emitToH $ text "extern kk_string_t" <+> conTagName con <.> semi let at = newHiddenName "at" + cpath = newHiddenName "cpath" + hasCPath = conReprHasCtxPath conRepr && not (null allFields) + (paddingFields,conFields) = partition (isPaddingName . fst) allFields emitToH $ text "static inline" <+> ppName (typeClassName (dataInfoName info)) <+> conCreateNameInfo con <.> ntparameters ((if (dataReprIsValue dataRepr || (null conFields) || isDataAsMaybe dataRepr) then [] else [(at,typeReuse)]) + ++ (if hasCPath then [(cpath,typeInt32)] else []) ++ conInfoParams con) <+> block ( let nameDoc = ppName (conInfoName con) @@ -649,14 +672,17 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount assignField f (name,tp) = f (ppDefName name) <+> text "=" <+> ppDefName name <.> semi in if (dataReprIsValue dataRepr) then vcat(--[ppName (typeClassName (dataInfoName info)) <+> tmp <.> semi] - (if (hasTagField dataRepr) + (if (needsTagField dataRepr) then [ ppName (typeClassName (dataInfoName info)) <+> tmp <.> semi , tmp <.> text "._tag =" <+> ppConTag con conRepr dataRepr <.> semi] ++ map (assignField (\fld -> tmp <.> text "._cons." <.> ppDefName (conInfoName con) <.> text "." <.> fld)) conFields - ++ [tmp <.> text "._cons._fields[" <.> pretty i <.> text "] = kk_box_null;" - | i <- [scanCount..(maxScanCount-1)]] + ++ [tmp <.> text "._cons." <.> ppDefName (conInfoName con) <.> text "." <.> ppDefName padding <+> text "= kk_box_null();" + | (padding,_) <- paddingFields] + ++ [tmp <.> text "._cons._fields[" <.> pretty i <.> text "] = kk_box_null();" + | i <- [(scanCount-1) .. (maxScanCount-2)]] -- -1 as the scanCount includes the struct tag field else [ ppName (typeClassName (dataInfoName info)) <+> tmp <.> semi {- <+> text "= {0}; // zero initializes all fields" -} ] ++ map (assignField (\fld -> tmp <.> text "." <.> fld)) conFields + ++ [tmp <.> text "." <.> ppDefName padding <+> text "= kk_box_null();" | (padding,_) <- paddingFields] ) ++ [text "return" <+> tmp <.> semi]) else {- if (null conFields) @@ -664,7 +690,7 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount else -} vcat((if not (isConAsJust conRepr) then [] else let arg = ppName (fst (head (conInfoParams con))) - in [text "if (kk_likely(!kk_box_is_maybe(" <.> arg <.> text "))) { return kk_datatype_as_Just(" <.> arg <.> text "); }" + in [text "if kk_likely(!kk_box_is_maybe" <.> arguments [arg] <.> text ") { return kk_datatype_as_Just(" <.> arg <.> text "); }" ]) ++ [text "struct" <+> nameDoc <.> text "*" <+> tmp <+> text "=" @@ -672,18 +698,21 @@ genConstructorCreate info dataRepr con conRepr conFields scanCount maxScanCount <.> arguments [ text "struct" <+> nameDoc, (if (isDataAsMaybe dataRepr || null conFields {- open singleton -}) then text "kk_reuse_null" else ppName at), pretty scanCount <+> text "/* scan count */", + (if hasCPath then ppName cpath else text "0"), if (dataRepr /= DataOpen) - then ppConTag con conRepr dataRepr - else text "KK_TAG_OPEN"] + then ppConTag con conRepr dataRepr + else text "KK_TAG_OPEN" + ] <.> semi] - ++ (if (dataRepr /= DataOpen) then [] else [tmp <.> text "->_base._tag = kk_string_dup" <.> parens(ppConTag con conRepr dataRepr) <.> semi ]) + ++ (if (dataRepr /= DataOpen) then [] else [tmp <.> text "->_base._tag = kk_string_dup" <.> arguments [ppConTag con conRepr dataRepr] <.> semi ]) ++ map (assignField (\fld -> tmp <.> text "->" <.> fld)) conFields + ++ [tmp <.> text "->" <.> ppDefName padding <+> text "= kk_box_null();" | (padding,_) <- paddingFields] ++ {- [let base = text "&" <.> tmp <.> text "->_base" in if (dataReprMayHaveSingletons dataRepr) then text "return kk_datatype_from_base" <.> parens base <.> semi else text "return" <+> base <.> semi]) -} - [text "return" <+> conBaseCastNameInfo con <.> parens tmp <.> semi]) + [text "return" <+> conBaseCastNameInfo con <.> arguments [tmp] <.> semi]) ) genConstructorBaseCast :: DataInfo -> DataRepr -> ConInfo -> ConRepr -> Asm () @@ -695,12 +724,10 @@ genConstructorBaseCast info dataRepr con conRepr _ | dataReprIsValue dataRepr -> return () _ -> emitToH $ text "static inline" <+> ppName (typeClassName (dataInfoName info)) <+> conBaseCastNameInfo con - <.> tupled [text "struct" <+> ppName (conInfoName con) <.> text "* _x"] + <.> parameters [text "struct" <+> ppName (conInfoName con) <.> text "* _x"] <+> block ( let base = text "&_x->_base" - in if (dataReprMayHaveSingletons dataRepr) - then text "return kk_datatype_from_base" <.> parens base <.> semi - else text "return" <+> base <.> semi + in text "return" <+> text "kk_datatype_from_base" <.> arguments [base] <.> semi ) @@ -711,13 +738,13 @@ genConstructorAccess info dataRepr con conRepr else gen where gen = emitToH $ text "static inline struct" <+> ppName (conInfoName con) <.> text "*" <+> conAsName con - <.> tupled [ppName (typeClassName (dataInfoName info)) <+> text "x"] + <.> parameters [ppName (typeClassName (dataInfoName info)) <+> text "x"] <+> block( vcat $ [-- text "assert(" <.> conTestName con <.> tupled [text "x"] <.> text ");", text "return" <+> - text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_as_assert" else "kk_basetype_as_assert") <.> - tupled [text "struct" <+> ppName (conInfoName con) <.> text "*", text "x", - (if (dataRepr == DataOpen) then text "KK_TAG_OPEN" else ppConTag con conRepr dataRepr <+> text "/* _tag */")] <.> semi] + text "kk_datatype_as_assert" <.> + arguments [text "struct" <+> ppName (conInfoName con) <.> text "*", text "x", + (if (dataRepr == DataOpen) then text "KK_TAG_OPEN" else ppConTag con conRepr dataRepr)] <.> semi] ) @@ -727,18 +754,34 @@ genBoxUnbox name info dataRepr genBox tname info dataRepr genUnbox tname info dataRepr - -genBoxCall prim asBorrowed tp arg - = case cType tp of - CFun _ _ -> primName_t prim "function_t" <.> parens arg - CPrim val | val == "kk_unit_t" || val == "kk_integer_t" || val == "bool" || val == "kk_string_t" +genBoxCall tp arg + = let prim = "box" + ctx = contextDoc + in case cType tp of + CFun _ _ -> primName_t prim "function_t" <.> tupled ([arg,ctx]) + CPrim val | val == "kk_unit_t" || val == "bool" || val == "kk_string_t" -- || val == "kk_integer_t" -> primName_t prim val <.> parens arg -- no context - --CPrim val | val == "int32_t" || val == "double" || val == "unit_t" - -- -> text val <.> arguments [arg] CData name -> primName prim (ppName name) <.> tupled [arg,ctx] _ -> primName_t prim (show (ppType tp)) <.> tupled [arg,ctx] -- kk_box_t, int32_t - where - ctx = if asBorrowed then text "NULL" else contextDoc + + +genUnboxCallOwned tp arg + = genUnboxCall tp arg (text "KK_OWNED") + +genUnboxCallBorrowed tp arg + = genUnboxCall tp arg (text "KK_BORROWED") + +genUnboxCall tp arg argBorrow + = let prim = "unbox" + ctx = contextDoc + in case cType tp of + CFun _ _ -> primName_t prim "function_t" <.> tupled [arg,ctx] -- no borrow + CPrim val | val == "kk_unit_t" || val == "bool" || val == "kk_string_t" + -> primName_t prim val <.> parens arg -- no borrow, no context + | otherwise + -> primName_t prim val <.> tupled ([arg] ++ (if (cPrimCanBeBoxed val) then [argBorrow] else []) ++ [ctx]) + CData name -> primName prim (ppName name) <.> tupled [arg,argBorrow,ctx] + CBox -> primName_t prim (show (ppType tp)) <.> tupled [arg,ctx] primName_t prim s = primName prim $ text $ @@ -747,6 +790,12 @@ primName_t prim s = primName prim $ text $ primName prim d = d <.> text "_" <.> text prim +dataStructAsMaybeSplit :: [ConInfo] -> (ConInfo,ConInfo) +dataStructAsMaybeSplit [conInfo1,conInfo2] + = if (null (conInfoParams conInfo1)) then (conInfo1,conInfo2) else (conInfo2,conInfo1) +dataStructAsMaybeSplit _ + = failure $ "Backend.C.dataStructAsMaybeSplit: invalid constructors for a maybe like type" + genBox name info dataRepr = emitToH $ text "static inline kk_box_t " <.> ppName name <.> text "_box" <.> parameters [ppName name <+> text "_x"] <+> block ( @@ -754,75 +803,71 @@ genBox name info dataRepr DataEnum -> text "return" <+> text "kk_enum_box" <.> tupled [text "_x"] <.> semi DataIso -> let conInfo = head (dataInfoConstrs info) (isoName,isoTp) = (head (conInfoParams conInfo)) - in text "return" <+> genBoxCall "box" False isoTp (text "_x." <.> ppName (unqualify isoName)) <.> semi - DataStructAsMaybe - -> let [conNothing,conJust] = sortOn (length . conInfoParams) (dataInfoConstrs info) + in text "return" <+> genBoxCall isoTp (text "_x." <.> ppName (unqualify isoName)) <.> semi + DataStructAsMaybe + -> let (conNothing,conJust) = dataStructAsMaybeSplit (dataInfoConstrs info) (conJustFieldName,conJustFieldTp) = head (conInfoParams conJust) - in text "if" <+> parens (conTestName conNothing <.> tupled [text "_x"]) <+> (text "return kk_box_Nothing();") + in text "if" <+> parens (conTestName conNothing <.> arguments [text "_x"]) <+> (text "{ return kk_box_Nothing(); }") <-> text " else" <+> ( - let boxField = genBoxCall "box" False conJustFieldTp + let boxField = genBoxCall conJustFieldTp (text "_x._cons." <.> ppDefName (conInfoName conJust) <.> text "." <.> ppName (unqualify conJustFieldName)) - in text "return kk_box_Just" <.> arguments [boxField] <.> semi + in text "{ return kk_box_Just" <.> arguments [boxField] <.> semi <+> text "}" ) _ -> case dataInfoDef info of - DataDefValue raw scancount - -> let -- extra = if (hasTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors - docScanCount = if (hasTagField dataRepr) - then ppName name <.> text "_scan_count" <.> parens (text "_x") - else pretty scancount <+> text "/* scan count */" + DataDefValue (ValueRepr raw scancount alignment) + -> let -- extra = if (needsTagField dataRepr) then 1 else 0 -- adjust scan count for added "tag_t" members in structs with multiple constructors + docScanCount = {- if (needsTagField dataRepr) + then ppName name <.> text "_scan_count" <.> arguments [text "_x"] + else -} + pretty (scancount {- + extra -}) <+> text "/* scan count */" in vcat [ text "kk_box_t _box;" , text "kk_valuetype_box" <.> arguments [ppName name, text "_box", text "_x", docScanCount ] <.> semi , text "return _box;" ] - _ -> text "return" <+> text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_box" else "kk_basetype_box") <.> tupled [text "_x"] <.> semi + _ -> text "return" <+> text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_box" else "kk_datatype_ptr_box") <.> tupled [text "_x"] <.> semi ) genUnbox name info dataRepr = emitToH $ - text "static inline" <+> ppName name <+> ppName name <.> text "_unbox" <.> parameters [text "kk_box_t _x"] <+> block ( + text "static inline" <+> ppName name <+> ppName name <.> text "_unbox" <.> parameters [text "kk_box_t _x", text "kk_borrow_t _borrow"] <+> block ( (case dataRepr of DataEnum -> text "return" <+> parens (ppName name) <.> text "kk_enum_unbox" <.> tupled [text "_x"] DataIso -> let conInfo = head (dataInfoConstrs info) isoTp = snd (head (conInfoParams conInfo)) - in text "return" <+> conCreateNameInfo conInfo <.> arguments [genBoxCall "unbox" False isoTp (text "_x")] + in text "return" <+> conCreateNameInfo conInfo <.> arguments [genUnboxCall isoTp (text "_x") (text "_borrow")] DataStructAsMaybe -> let [conNothing,conJust] = sortOn (length . conInfoParams) (dataInfoConstrs info) (conJustFieldName,conJustFieldTp) = head (conInfoParams conJust) in text "if (kk_box_is_Nothing(_x))" <+> - text "return" <+> conCreateName (conInfoName conNothing) <.> arguments [] <.> semi + text "{ return" <+> conCreateName (conInfoName conNothing) <.> arguments [] <.> semi <+> text "}" <-> text " else" <+> ( - text "return" <+> conCreateName (conInfoName conJust) <.> arguments [ - genBoxCall "unbox" False conJustFieldTp (text "kk_unbox_Just" <.> arguments [text "_x"]) - ] <.> semi + text "{ return" <+> conCreateName (conInfoName conJust) <.> arguments [ + genUnboxCall conJustFieldTp (text "kk_unbox_Just" <.> arguments [text "_x", text "_borrow"]) (text "_borrow") + ] <.> semi <+> text "}" ) _ | dataReprIsValue dataRepr - -> vcat [ text "kk_boxed_value_t _p;" - , ppName name <+> text "_unbox;" - , text "kk_valuetype_unbox_" <.> arguments [ppName name, text "_p", text "_unbox", text "_x"] <.> semi -- borrowing - , text "if (_ctx!=NULL && _p!=NULL)" <+> block ( - text "if (kk_basetype_is_unique(_p)) { kk_basetype_free(_p,_ctx); } else" <+> block ( - vcat [ppName name <.> text "_dup(_unbox);" - ,text "kk_basetype_decref" <.> arguments [text "_p"] <.> semi] - ) - ) - -- , text "else {" <+> ppName name <.> text "_dup(_unbox); }" + -> vcat [ ppName name <+> text "_unbox;" + , text "kk_valuetype_unbox" <.> arguments [ppName name, text "_unbox", text "_x", text "_borrow"] <.> semi , text "return _unbox" ] -- text "unbox_valuetype" <.> arguments [ppName name, text "x"] _ -> text "return" - <+> (if dataReprMayHaveSingletons dataRepr - then text "kk_datatype_unbox(_x)" - else text "kk_basetype_unbox_as" <.> tupled [ppName name, text "_x"]) + <+> ((if dataReprMayHaveSingletons dataRepr + then text "kk_datatype_unbox" + else text "kk_datatype_ptr_unbox") + <.> tupled [text "_x"]) ) <.> semi) +-- con infos are sorted with singletons first genDupDrop :: Name -> DataInfo -> DataRepr -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Asm () genDupDrop name info dataRepr conInfos - = do genScanFields name info dataRepr conInfos + = do -- genScanFields name info dataRepr conInfos genDupDropX True name info dataRepr conInfos genDupDropX False name info dataRepr conInfos + {- when (not (dataReprIsValue dataRepr)) $ do genHole name info dataRepr -- create "hole" of this type for TRMC when (not (isDataAsMaybe dataRepr)) $ @@ -832,125 +877,156 @@ genDupDrop name info dataRepr conInfos genDropReuseFun name info dataRepr -- drop, but if refcount==0 return the address of the block instead of freeing genDropNFun name info dataRepr -- drop with known number of scan fields genReuse name info dataRepr -- return the address of the block - - + -} +{- genIsUnique :: Name -> DataInfo -> DataRepr -> Asm () genIsUnique name info dataRepr = emitToH $ - text "static inline bool" <+> ppName name <.> text "_is_unique" <.> tupled [ppName name <+> text "_x"] <+> block ( - text "return" <+> - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_is_unique(_x)" - else text "kk_basetype_is_unique(_x)" - ) <.> semi) + text "static inline bool" <+> ppName name <.> text "_is_unique" <.> parameters [ppName name <+> text "_x"] <+> block ( + text "return" <+> text "kk_datatype_ptr_is_unique" <.> arguments [text "_x"] <.> semi + ) genFree :: Name -> DataInfo -> DataRepr -> Asm () genFree name info dataRepr = emitToH $ text "static inline void" <+> ppName name <.> text "_free" <.> parameters [ppName name <+> text "_x"] <+> block ( - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_free" - else text "kk_basetype_free" - ) <.> arguments [text "_x"] <.> semi) + text "kk_datatype_ptr_free" <.> arguments [text "_x"] <.> semi + ) genDecRef :: Name -> DataInfo -> DataRepr -> Asm () genDecRef name info dataRepr = emitToH $ text "static inline void" <+> ppName name <.> text "_decref" <.> parameters [ppName name <+> text "_x"] <+> block ( - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_decref" - else text "kk_basetype_decref" - ) <.> arguments [text "_x"] <.> semi) + text "kk_datatype_ptr_decref" <.> arguments [text "_x"] <.> semi + ) genDropReuseFun :: Name -> DataInfo -> DataRepr -> Asm () genDropReuseFun name info dataRepr = emitToH $ text "static inline kk_reuse_t" <+> ppName name <.> text "_dropn_reuse" <.> parameters [ppName name <+> text "_x", text "kk_ssize_t _scan_fsize"] <+> block ( - text "return" <+> - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_dropn_reuse" - else text "kk_basetype_dropn_reuse" - ) <.> arguments [text "_x", text "_scan_fsize"] <.> semi) + text "return" <+> text "kk_datatype_ptr_dropn_reuse" <.> arguments [text "_x", text "_scan_fsize"] <.> semi + ) genDropNFun :: Name -> DataInfo -> DataRepr -> Asm () genDropNFun name info dataRepr = emitToH $ text "static inline void" <+> ppName name <.> text "_dropn" <.> parameters [ppName name <+> text "_x", text "kk_ssize_t _scan_fsize"] <+> block ( - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_dropn" - else text "kk_basetype_dropn" - ) <.> arguments [text "_x", text "_scan_fsize"] <.> semi) + text "kk_datatype_ptr_dropn" <.> arguments [text "_x", text "_scan_fsize"] <.> semi) genReuse :: Name -> DataInfo -> DataRepr -> Asm () genReuse name info dataRepr = emitToH $ - text "static inline kk_reuse_t" <+> ppName name <.> text "_reuse" <.> tupled [ppName name <+> text "_x"] <+> block ( - text "return" <+> - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_reuse(_x)" - else text "kk_basetype_reuse(_x)" - ) <.> semi) + text "static inline kk_reuse_t" <+> ppName name <.> text "_reuse" <.> parameters [ppName name <+> text "_x"] <+> block ( + text "return" <+> text "kk_datatype_ptr_reuse" <.> arguments [text "_x"] <.> semi) genHole :: Name -> DataInfo -> DataRepr -> Asm () genHole name info dataRepr = emitToH $ - text "static inline" <+> ppName name <+> ppName name <.> text "_hole()" <+> block ( + text "static inline" <+> ppName name <+> ppName name <.> text "_hole(void)" <+> block ( text "return" <+> -- holes must be trace-able and look like values (least-significant-bit==1) - (if (dataReprMayHaveSingletons dataRepr) - then text "kk_datatype_from_tag((kk_tag_t)0)" - else parens (ppName name) <.> text "(1)" - ) <.> semi) - + text "kk_datatype_null()" <.> semi) +-} +{- genScanFields :: Name -> DataInfo -> DataRepr -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Asm () -genScanFields name info dataRepr conInfos | not (hasTagField dataRepr) +genScanFields name info dataRepr conInfos | not (needsTagField dataRepr) = return () genScanFields name info dataRepr conInfos = emitToH $ - text "static inline kk_ssize_t" <+> ppName name <.> text "_scan_count" <.> tupled [ppName name <+> text "_x"] + text "static inline kk_ssize_t" <+> ppName name <.> text "_scan_count" <.> parameters [ppName name <+> text "_x"] <+> block (vcat (map (genScanFieldTests (length conInfos)) (zip conInfos [1..]))) genScanFieldTests :: Int -> ((ConInfo,ConRepr,[(Name,Type)],Int),Int) -> Doc genScanFieldTests lastIdx ((con,conRepr,conFields,scanCount),idx) = if (lastIdx == idx) then (text "else" <+> stat) - else (text (if (idx==1) then "if" else "else if") <+> parens (conTestName con <.> tupled [text "_x"])) + else (text (if (idx==1) then "if" else "else if") <+> parens (conTestName con <.> arguments [text "_x"])) <+> stat where stat = text ("return " ++ show (1 {-tag-} + scanCount) ++ ";") +-} genDupDropX :: Bool -> Name -> DataInfo -> DataRepr -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Asm () genDupDropX isDup name info dataRepr conInfos = emitToH $ text "static inline" <+> (if isDup then ppName name <+> ppName name <.> text "_dup" else text "void" <+> ppName name <.> text "_drop") - <.> (if isDup then tupled else parameters) [ppName name <+> text "_x"] + <.> parameters [ppName name <+> text "_x"] <+> block (vcat (dupDropTests)) where ret = (if isDup then [text "return _x;"] else []) dupDropTests | dataRepr == DataEnum = ret + | all (\(_,conRepr,_,_) -> isConSingleton conRepr) conInfos = ret -- for ref type enumerations | dataRepr == DataIso = [genDupDropIso isDup (head conInfos)] ++ ret - | dataRepr <= DataStruct = map (genDupDropTests isDup dataRepr (length conInfos)) (zip conInfos [1..]) ++ ret + -- | dataRepr == DataStructAsMaybe = [genDupDropMaybe isDup conInfos] ++ ret + | dataRepr <= DataStruct = genDupDropMatch (map (genDupDropTests isDup dataRepr) conInfos) ++ ret + {- + case (dataInfoDef info) of + DataDefValue _ scancount -> genDupDropValue isDup dataRepr scancount ++ ret + _ -> failure "Backend.C.genDupDropX: invalid value data definition?" + -} | otherwise = if (isDup) then [text "return" <+> (if dataReprMayHaveSingletons dataRepr - then text "kk_datatype_dup(_x)" - else text "kk_basetype_dup_as" <.> tupled [ppName name, text "_x"]) + then text "kk_datatype_dup" <.> arguments [text "_x"] + else -- text "kk_basetype_dup_as" <.> arguments [ppName name, text "_x"]) + text "kk_datatype_ptr_dup" <.> arguments [text "_x"]) <.> semi] - else [text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_drop" else "kk_basetype_drop") + else [text (if dataReprMayHaveSingletons dataRepr then "kk_datatype_drop" + else "kk_datatype_ptr_drop") <.> arguments [text "_x"] <.> semi] genDupDropIso :: Bool -> (ConInfo,ConRepr,[(Name,Type)],Int) -> Doc genDupDropIso isDup (con,conRepr,[(name,tp)],scanCount) = hcat $ map (<.>semi) (genDupDropCall isDup tp (text "_x." <.> ppName name)) genDupDropIso _ _ - = failure $ "Backend.C.genDupDropIso: ivalid arguments" + = failure $ "Backend.C.genDupDropIso: invalid arguments" + +-- coninfos are sorted with singletons first +genDupDropMaybe :: Bool -> [(ConInfo,ConRepr,[(Name,Type)],Int)] -> Doc +genDupDropMaybe isDup [(conNothing,_,_,_),(conJust,_,[(fname,ftp)],_)] + = text "if" <+> parens (text "!" <.> conTestName conNothing <.> arguments [text "_x"]) <+> + (block $ vcat (genDupDropCall isDup ftp (text "_x._cons." <.> ppDefName (conInfoName conJust) <.> dot <.> ppName fname)) <.> semi) + +{- +genDupDropValue :: Bool -> DataRepr -> Int -> [Doc] +genDupDropValue isDup dataRepr 0 = [] +-- genDupDropValue isDup DataStructAsMaybe 1 -- todo: maybe specialize? +genDupDropValue isDup dataRepr scanCount + = [text "kk_box_t* _fields = (kk_box_t*)" <.> text (if needsTagField dataRepr then "&_x._cons._fields" else "&_x") <.> semi] + ++ + [text "kk_box_" <.> text (if isDup then "dup" else "drop") <.> arguments [text "_fields[" <.> pretty (i-1) <.> text "]"] <.> semi + | i <- [1..scanCount]] +-} -genDupDropTests :: Bool -> DataRepr -> Int -> ((ConInfo,ConRepr,[(Name,Type)],Int),Int) -> Doc -genDupDropTests isDup dataRepr lastIdx ((con,conRepr,conFields,scanCount),idx) +block1 [stat] = text "{" <+> stat <+> text "}" +block1 stats = block (vcat stats) + +genDupDropMatch :: [(Doc,[Doc])] -> [Doc] +genDupDropMatch branches0 + = let branches = filter (not . null . snd) branches0 + complete = (length branches == length branches0) + genBranch iff (test,stats) + = text iff <+> parens test <+> block1 stats + in case branches of + [] -> [] + [(_,stats)] | (null stats || complete) + -> stats + (b:bs) -> [genBranch "if" b] ++ + [genBranch "else if" b | b <- if complete then init bs else bs] ++ + (if complete then [text "else" <+> block1 (snd (last bs))] else []) + +genDupDropTests :: Bool -> DataRepr -> (ConInfo,ConRepr,[(Name,Type)],Int) -> (Doc,[Doc]) +genDupDropTests isDup dataRepr (con,conRepr,conFields,scanCount) + = let dupdropFields = genDupDropFields isDup dataRepr con conFields + in (conTestName con <.> arguments [text "_x"], dupdropFields) + + +genDupDropTestsX :: Bool -> DataRepr -> Int -> ((ConInfo,ConRepr,[(Name,Type)],Int),Int) -> Doc +genDupDropTestsX isDup dataRepr lastIdx ((con,conRepr,conFields,scanCount),idx) = let stats = genDupDropFields isDup dataRepr con conFields in if (lastIdx == idx) then (if null stats @@ -958,14 +1034,14 @@ genDupDropTests isDup dataRepr lastIdx ((con,conRepr,conFields,scanCount),idx) else if (lastIdx == 1) then vcat stats else text "else" <+> block (vcat stats)) - else (text (if (idx==1) then "if" else "else if") <+> parens (conTestName con <.> tupled [text "_x"])) + else (text (if (idx==1) then "if" else "else if") <+> parens (conTestName con <.> arguments [text "_x"])) <+> (if null stats then text "{ }" else block (vcat stats)) genDupDropFields :: Bool -> DataRepr -> ConInfo -> [(Name,Type)] -> [Doc] genDupDropFields isDup dataRepr con conFields = map (\doc -> doc <.> semi) $ concat $ [genDupDropCall isDup tp - ((if (hasTagField dataRepr) then text "_x._cons." <.> ppDefName (conInfoName con) else text "_x") + ((if (needsTagField dataRepr) then text "_x._cons." <.> ppDefName (conInfoName con) else text "_x") <.> dot <.> ppName name) | (name,tp) <- conFields] @@ -984,28 +1060,48 @@ genDupCall tp arg = hcat $ genDupDropCall True tp arg genDropCall tp arg = hcat $ genDupDropCall False tp arg genDupDropCall :: Bool -> Type -> Doc -> [Doc] -genDupDropCall isDup tp arg = if (isDup) then genDupDropCallX "dup" tp (parens arg) +genDupDropCall isDup tp arg = if (isDup) then genDupDropCallX "dup" tp (arguments [arg]) else genDupDropCallX "drop" tp (arguments [arg]) + +-- The following functions are generated during "drop specialization" and "reuse specialization", +-- and only generated for heap allocated constructors so we can always use the `datatype_ptr` calls at runtime. genIsUniqueCall :: Type -> Doc -> [Doc] -genIsUniqueCall tp arg = case genDupDropCallX "is_unique" tp (parens arg) of +genIsUniqueCall tp arg = {- case genDupDropCallX "is_unique" tp (arguments [arg]) of [call] -> [text "kk_likely" <.> parens call] cs -> cs + -} + [text "kk_likely" <.> parens (text "kk_datatype_ptr_is_unique" <.> arguments [arg])] + genFreeCall :: Type -> Doc -> [Doc] -genFreeCall tp arg = genDupDropCallX "free" tp (arguments [arg]) +genFreeCall tp arg = -- genDupDropCallX "free" tp (arguments [arg]) + [text "kk_datatype_ptr_free" <.> arguments [arg]] genDecRefCall :: Type -> Doc -> [Doc] -genDecRefCall tp arg = genDupDropCallX "decref" tp (arguments [arg]) +genDecRefCall tp arg = -- genDupDropCallX "decref" tp (arguments [arg]) + [text "kk_datatype_ptr_decref" <.> arguments [arg]] genDropReuseCall :: Type -> [Doc] -> [Doc] -genDropReuseCall tp args = genDupDropCallX "dropn_reuse" tp (arguments args) +genDropReuseCall tp args = -- genDupDropCallX "dropn_reuse" tp (arguments args) + [text "kk_datatype_ptr_dropn_reuse" <.> arguments args] genReuseCall :: Type -> Doc -> [Doc] -genReuseCall tp arg = genDupDropCallX "reuse" tp (parens arg) +genReuseCall tp arg = -- genDupDropCallX "reuse" tp (arguments [arg]) + [text "kk_datatype_ptr_reuse" <.> arguments [arg]] genDropNCall :: Type -> [Doc] -> [Doc] -genDropNCall tp args = genDupDropCallX "dropn" tp (arguments args) +genDropNCall tp args = -- genDupDropCallX "dropn" tp (arguments args) + [text "kk_datatype_ptr_dropn" <.> arguments args] + +genHoleCall :: Type -> Doc +genHoleCall tp = -- ppType tp <.> text "_hole()") + case cType tp of + CPrim "kk_integer_t" -> text "kk_integer_zero" + CPrim "kk_string_t" -> text "kk_string_empty()" + CPrim "kk_vector_t" -> text "kk_vector_empty()" + _ -> text "kk_datatype_null()" + conBaseCastNameInfo :: ConInfo -> Doc conBaseCastNameInfo con = conBaseCastName (conInfoName con) @@ -1090,14 +1186,23 @@ genLambda params eff body funTpName = postpend "_t" funName structDoc = text "struct" <+> ppName funTpName freeVars = [(nm,tp) | (TName nm tp) <- tnamesList (freeLocals (Lam params eff body))] - newtypes <- getNewtypes + platform <- getPlatform - let (fields,_,scanCount) = orderConFieldsEx platform newtypes False freeVars - fieldDocs = [ppType tp <+> ppName name | (name,tp) <- fields] - tpDecl = text "struct" <+> ppName funTpName <+> block ( + env <- getEnv + let emitError doc = do let msg = show doc + failure ("Backend.C.genLambda: " ++ msg) + nameDoc = text (show (cdefName env) ++ ".") + getDataInfo name = do newtypes <- getNewtypes + return (newtypesLookupAny name newtypes) + (allFields,vrepr) <- orderConFields emitError nameDoc getDataInfo platform 1 {- base.fun -} freeVars + + let (paddingFields,fields) = partition (isPaddingName . fst) allFields + scanCount = valueReprScanCount vrepr + -- fieldDocs = [ppType tp <+> ppName name | (name,tp) <- allFields] + tpDecl = text "struct" <+> ppName funTpName <+> block ( vcat ([text "struct kk_function_s _base;"] ++ - [ppType tp <+> ppName name <.> semi | (name,tp) <- fields]) - ) <.> semi + [ppType tp <+> ppName name <.> semi | (name,tp) <- allFields]) + ) <.> semi -- <-> text "kk_struct_packed_end" funSig = text (if toH then "extern" else "static") <+> ppType (typeOf body) <+> ppName funName <.> parameters ([text "kk_function_t _fself"] ++ @@ -1110,12 +1215,13 @@ genLambda params eff body then [text "kk_define_static_function" <.> arguments [text "_fself", ppName funName] -- <.> semi --text "static" <+> structDoc <+> text "_self =" -- <+> braces (braces (text "static_header(1, TAG_FUNCTION), box_cptr(&" <.> ppName funName <.> text ")")) <.> semi - ,text "return kk_function_dup(_fself);"] - else [structDoc <.> text "* _self = kk_function_alloc_as" <.> arguments [structDoc, pretty (scanCount + 1) -- +1 for the _base.fun + ,text "return kk_function_dup(_fself,kk_context());"] + else [structDoc <.> text "* _self = kk_function_alloc_as" <.> arguments [structDoc, pretty scanCount ] <.> semi - ,text "_self->_base.fun = kk_cfun_ptr_box(&" <.> ppName funName <.> text ", kk_context());"] + ,text "_self->_base.fun = kk_kkfun_ptr_box(&" <.> ppName funName <.> text ", kk_context());"] ++ [text "_self->" <.> ppName name <+> text "=" <+> ppName name <.> semi | (name,_) <- fields] - ++ [text "return &_self->_base;"]) + ++ [text "_self->" <.> ppName paddingName <+> text "= kk_box_null();" | (paddingName,_) <- paddingFields] + ++ [text "return kk_datatype_from_base(&_self->_base, kk_context());"]) ) @@ -1125,7 +1231,7 @@ genLambda params eff body let funDef = funSig <+> block ( (if (null fields) then text "kk_unused(_fself);" else let dups = braces (hcat [genDupCall tp (ppName name) <.> semi | (name,tp) <- fields]) - in vcat ([structDoc <.> text "* _self = kk_function_as" <.> tupled [structDoc <.> text "*",text "_fself"] <.> semi] + in vcat ([structDoc <.> text "* _self = kk_function_as" <.> arguments [structDoc <.> text "*",text "_fself"] <.> semi] ++ [ppType tp <+> ppName name <+> text "= _self->" <.> ppName name <.> semi <+> text "/*" <+> pretty tp <+> text "*/" | (name,tp) <- fields] ++ [text "kk_drop_match" <.> arguments [text "_self",dups,text "{}"]] )) @@ -1216,11 +1322,15 @@ cTypeCon c then CPrim "kk_box_t" else if (name == nameTpReuse) then CPrim "kk_reuse_t" - else if (name == nameTpCField) + else if (name == nameTpFieldAddr) then CPrim "kk_box_t*" else CData (typeClassName name) +cPrimCanBeBoxed :: String -> Bool +cPrimCanBeBoxed prim + = prim `elem` ["kk_char_t", "int64_t", "int16_t", "int32_t", "float", "double", "intptr_t", "kk_ssize_t"] + --------------------------------------------------------------------------------- -- Statements @@ -1279,16 +1389,20 @@ tryTailCall result expr = fmap (debugWrap "genOverride") $ do (stmts, varNames) <- do -- args' <- mapM tailCallArg args let args' = args - bs <- mapM genVarBinding args' + bs <- mapM (genTailVarBinding params) (zip params args') return (unzip bs) docs1 <- mapM genDefName params docs2 <- mapM genDefName varNames let assigns = map (\(p,a)-> if p == a then debugComment ("genOverride: skipped overriding `" ++ (show p) ++ "` with itself") - else debugComment ("genOverride: preparing tailcall") <.> p <+> text "=" <+> a <.> semi + else p <+> text "=" <+> a <.> semi ) (zip docs1 docs2) return $ vcat (stmts ++ assigns) + genTailVarBinding params (param,expr) + = case expr of + Var tn _ | tn /= param && tn `elem` params -> genVarBindingAlways expr + _ -> genVarBinding expr -- | Generates a statement from an expression by applying a return context (deeply) inside genStat :: Result -> Expr -> Asm Doc @@ -1347,6 +1461,8 @@ genExprStat result expr -- Match --------------------------------------------------------------------------------- +type Bindings = [(TName,Doc)] + -- | Generates a statement for a match expression regarding a given return context genMatch :: Result -> [Doc] -> [Branch] -> Asm Doc genMatch result0 exprDocs branches @@ -1401,48 +1517,60 @@ genMatch result0 exprDocs branches genBranch :: Result -> [Doc] -> Bool -> Branch -> Asm Doc genBranch result exprDocs doTest branch@(Branch patterns guards) - = do doc <- genPattern doTest (freeLocals guards) (zip exprDocs patterns) (genGuards result guards) + = do eagerPatBind <- getEagerPatBind + doc <- genPattern doTest eagerPatBind [] (zip exprDocs patterns) (genGuards result guards) if (doc `dstartsWith` "if") then return doc else return (block doc) -- for C++ we need to scope the locals or goto's can skip initialization -genGuards :: Result -> [Guard] -> Asm Doc -genGuards result guards - = do docs <- mapM (genGuard result) guards +genGuards :: Result -> [Guard] -> Bindings -> Asm Doc +genGuards result guards bindings + = do (docs, _) <- foldM (genGuard result) ([], bindings) guards return (vcat docs) -genGuard :: Result -> Guard-> Asm Doc -genGuard result (Guard guard expr) - = case guard of - Con tname repr | getName tname == nameTrue - -> genStat result expr - _ -> do (gddoc,gdoc) <- genExpr guard - sdoc <- genStat result expr - return (vcat gddoc <-> text "if" <+> parensIf gdoc <+> block (sdoc)) +genGuard :: Result -> ([Doc], Bindings) -> Guard -> Asm ([Doc], Bindings) +genGuard result (docs, bindings) (Guard guard expr) + = do let guardFree = freeLocals guard + exprFree = freeLocals expr + (bindsGuard,bindsOther) = partition (\(name,_) -> tnamesMember name guardFree) bindings + guardLocals = map snd bindsGuard + exprLocals = map snd (filter (\(name,_) -> tnamesMember name exprFree) bindsOther) + case guard of + Con tname repr | getName tname == nameTrue + -> do doc <- genStat result expr + return (docs ++ [vcat (guardLocals ++ exprLocals ++ [doc])], bindsOther) + _ -> do (gddoc,gdoc) <- genExpr guard + sdoc <- genStat result expr + return (docs ++ [vcat $ guardLocals ++ gddoc ++ [text "if" <+> parensIf gdoc <+> + block (vcat (exprLocals ++ [sdoc]))]], bindsOther) parensIf :: Doc -> Doc -- avoid parens if already parenthesized parensIf d - = if (dstartsWith d "(" && dendsWith d ")") then d else parens d + = if ((dstartsWith d "(" && dendsWith d ")") || + dstartsWith d "kk_likely") -- for genUniqueCall + then d else parens d + +genPattern :: Bool -> Bool -> Bindings -> [(Doc,Pattern)] -> (Bindings -> Asm Doc) -> Asm Doc +genPattern doTest eagerPatBind bindings [] genBody + = genBody bindings -genPattern :: Bool -> TNames -> [(Doc,Pattern)] -> Asm Doc -> Asm Doc -genPattern doTest gfree [] genBody - = genBody -genPattern doTest gfree dpatterns genBody - = do (testss,localss,nextPatternss) <- fmap (unzip3 . concat) $ - mapM (genPatternTest doTest gfree) dpatterns +genPattern doTest eagerPatBind bindings0 dpatterns genBody + = do (testss,localss,bindingss,nextPatternss) <- fmap (unzip4 . concat) $ + mapM (genPatternTest doTest eagerPatBind) dpatterns let tests = concat testss locals = concat localss + bindings = bindings0 ++ concat bindingss nextPatterns = concat nextPatternss - ndoc <- genPattern doTest gfree nextPatterns genBody + ndoc <- genPattern doTest eagerPatBind bindings nextPatterns genBody if (null tests) then return (vcat (locals ++ [ndoc])) else return (text "if" <+> parensIf (hcat (punctuate (text " && ") tests)) <+> block (vcat (locals ++ [ndoc]))) -genPatternTest :: Bool -> TNames -> (Doc,Pattern) -> Asm [([Doc],[Doc],[(Doc,Pattern)])] -genPatternTest doTest gfree (exprDoc,pattern) +genPatternTest :: Bool -> Bool -> (Doc,Pattern) -> Asm [([Doc],[Doc],Bindings,[(Doc,Pattern)])] +genPatternTest doTest eagerPatBind (exprDoc,pattern) = let test xs = if doTest then xs else [] in case pattern of PatWild -> return [] @@ -1462,34 +1590,38 @@ genPatternTest doTest gfree (exprDoc,pattern) return [([],[after],next)] -} PatCon bname [pattern] repr [targ] exists tres info skip | getName bname == nameBoxCon - -> do local <- newVarName "unbox" - let unbox = genBoxCall "unbox" True targ exprDoc - next = genNextPatterns (\self fld -> self) {-(ppDefName local)-} unbox targ [pattern] - -- assign = ppType targ <+> ppDefName local <+> text "=" <+> unbox <.> semi - return [([],[{-assign-}],next)] + -> do -- local <- newVarName "unbox" + let -- assign = [ppType tres <+> ppDefName local <+> text "=" <+> genDupCall tres exprDoc <.> semi] + -- unbox = genUnboxCallBorrowed targ (ppDefName local) + assign = [] + unbox = genUnboxCallBorrowed targ exprDoc + next = genNextPatterns (\self fld -> self) unbox targ [pattern] + return [([],assign,[],next)] PatVar tname pattern - -> do let after = if (patternVarFree pattern && not (tnamesMember tname gfree)) then [] - else [ppType (typeOf tname) <+> ppDefName (getName tname) <+> text "=" <+> exprDoc <.> semi] + -> do let binding = ppType (typeOf tname) <+> ppDefName (getName tname) <+> text "=" <+> exprDoc <.> semi + (assign,bindings) = if (patternVarFree pattern && not eagerPatBind) + then ([],[(tname,binding)]) -- read field as late as possible (for nested pattern matches) + else ([binding],[]) -- read field right away next = genNextPatterns (\self fld -> self) (ppDefName (getName tname)) (typeOf tname) [pattern] - return [([],after,next)] + return [([],assign,bindings,next)] PatLit (LitString s) - -> return [(test [text "kk_string_cmp_cstr_borrow" <.> tupled [exprDoc,fst (cstring s)] <+> text "== 0"],[],[])] + -> return [(test [text "kk_string_cmp_cstr_borrow" <.> arguments [exprDoc,fst (cstring s)] <+> text "== 0"],[],[],[])] PatLit lit@(LitInt _) - -> return [(test [text "kk_integer_eq_borrow" <.> arguments [exprDoc,ppLit lit]],[],[])] + -> return [(test [text "kk_integer_eq_borrow" <.> arguments [exprDoc,ppLit lit]],[],[],[])] PatLit lit - -> return [(test [exprDoc <+> text "==" <+> ppLit lit],[],[])] + -> return [(test [exprDoc <+> text "==" <+> ppLit lit],[],[],[])] PatCon tname patterns repr targs exists tres info skip -> -- trace ("patCon: " ++ show info ++ "," ++ show tname ++ ", " ++ show repr) $ case repr of ConEnum{} | conInfoName info == nameTrue - -> return [(xtest [exprDoc],[],[])] + -> return [(xtest [exprDoc],[],[],[])] ConEnum{} | conInfoName info == nameFalse - -> return [(xtest [text "!" <.> parens exprDoc],[],[])] + -> return [(xtest [text "!" <.> parens exprDoc],[],[],[])] ConAsJust{} -> do let next = genNextPatterns (\self fld -> text "kk_datatype_unJust" <.> arguments [self]) exprDoc (typeOf tname) patterns - return [(xtest [conTestName info <.> parens exprDoc],[],next)] + return [(xtest [conTestName info <.> arguments [exprDoc]],[],[],next)] _ -> let dataRepr = conDataRepr repr in if (dataReprIsValue dataRepr || isConSingleton repr) then valTest tname info dataRepr @@ -1497,22 +1629,22 @@ genPatternTest doTest gfree (exprDoc,pattern) where xtest xs = if skip then [] else test xs - valTest :: TName -> ConInfo -> DataRepr -> Asm [([Doc],[Doc],[(Doc,Pattern)])] + valTest :: TName -> ConInfo -> DataRepr -> Asm [([Doc],[Doc],Bindings,[(Doc,Pattern)])] valTest conName conInfo dataRepr = --do let next = genNextPatterns (exprDoc) (typeOf tname) patterns -- return [(test [conTestName conInfo <.> parens exprDoc],[assign],next)] - do let selectOp = if (hasTagField dataRepr) + do let selectOp = if (needsTagField dataRepr) then "._cons." ++ show (ppDefName (getName conName)) ++ "." else "." next = genNextPatterns (\self fld -> self <.> text selectOp <.> fld) exprDoc (typeOf tname) patterns - return [(xtest [conTestName conInfo <.> tupled [exprDoc]],[],next)] + return [(xtest [conTestName conInfo <.> arguments [exprDoc]],[],[],next)] conTest conInfo = do local <- newVarName "con" let next = genNextPatterns (\self fld -> self <.> text "->" <.> fld) (ppDefName local) (typeOf tname) patterns typeDoc = text "struct" <+> ppName (conInfoName conInfo) <.> text "*" - assign = typeDoc <+> ppDefName local <+> text "=" <+> conAsName conInfo <.> tupled [exprDoc] <.> semi - return [(xtest [conTestName conInfo <.> parens exprDoc],[assign],next)] + assign = typeDoc <+> ppDefName local <+> text "=" <+> conAsName conInfo <.> arguments [exprDoc] <.> semi + return [(xtest [conTestName conInfo <.> arguments [exprDoc]],[assign],[],next)] patternVarFree pat = case pat of @@ -1587,8 +1719,8 @@ genExprPrim expr if (s=="") then return ([],text "kk_string_empty()") else do let (cstr,clen) = cstring s - return ([text "kk_define_string_literal" <.> tupled [empty,ppName name,pretty clen,cstr]] - ,text "kk_string_dup" <.> parens (ppName name)); + return ([text "kk_define_string_literal" <.> arguments [empty,ppName name,pretty clen,cstr]] + ,text "kk_string_dup" <.> arguments [ppName name]); Var vname (InfoExternal formats) -> case splitFunScheme (typeOf vname) of @@ -1635,13 +1767,16 @@ genVarBinding :: Expr -> Asm (Doc, TName) genVarBinding expr = case expr of Var tn _ | not (isQualified (getName tn))-> return $ (empty, tn) - _ -> do name <- newVarName "x" - let tp = typeOf expr - tname = TName name tp - doc <- genStat (ResultAssign tname Nothing) expr - if (dstartsWith doc (show (ppName name) ++ " =")) - then return (ppType tp <+> doc, tname) - else return (ppVarDecl tname <.> unitSemi tp <-> doc, tname) + _ -> genVarBindingAlways expr + +genVarBindingAlways expr + = do name <- newVarName "x" + let tp = typeOf expr + tname = TName name tp + doc <- genStat (ResultAssign tname Nothing) expr + if (dstartsWith doc (show (ppName name) ++ " =")) + then return (ppType tp <+> doc, tname) + else return (ppVarDecl tname <.> unitSemi tp <-> doc, tname) --------------------------------------------------------------------------------- @@ -1751,46 +1886,52 @@ genAppNormal :: Expr -> [Expr] -> Asm ([Doc],Doc) genAppNormal (Var allocAt _) [Var at _, App (Con tname repr) args] | getName allocAt == nameAllocAt = do (decls,argDocs) <- genInlineableExprs args let atDoc = ppName (getName at) - return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ argDocs)) + return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ ppCtxPath repr tname (null args) ++ argDocs)) genAppNormal (Var allocAt _) [Var at _, App (TypeApp (Con tname repr) targs) args] | getName allocAt == nameAllocAt = do (decls,argDocs) <- genInlineableExprs args let atDoc = ppName (getName at) - return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ argDocs)) + return (decls,conCreateName (getName tname) <.> arguments ([atDoc] ++ ppCtxPath repr tname (null args) ++ argDocs)) genAppNormal v@(Var allocAt _) [at, Let dgs expr] | getName allocAt == nameAllocAt -- can happen due to box operations = genExpr (Let dgs (App v [at,expr])) -- special: conAssignFields -genAppNormal (Var (TName conTagFieldsAssign typeAssign) _) (Var reuseName (InfoConField conName nameNil):(Var tag _):fieldValues) | conTagFieldsAssign == nameConTagFieldsAssign +genAppNormal (Var (TName conTagFieldsAssign typeAssign) _) (Var reuseName (InfoConField conName conRepr nameNil):(Var tag _):fieldValues) | conTagFieldsAssign == nameConTagFieldsAssign = do tmp <- genVarName "con" let setTag = tmp <.> text "->_base._block.header.tag = (kk_tag_t)" <.> parens (text (show tag)) <.> semi fieldNames = case splitFunScheme typeAssign of Just (_,_,args,_,_) -> tail (tail (map fst args)) _ -> failure ("Backend.C.FromCore: illegal conAssignFields type: " ++ show (pretty typeAssign)) - (decls, tmpDecl, assigns, result) <- genAssignFields tmp conName reuseName fieldNames fieldValues + (decls, tmpDecl, assigns, result) <- genAssignFields tmp conName conRepr reuseName fieldNames fieldValues return (decls ++ [tmpDecl, setTag] ++ assigns, result) -genAppNormal (Var (TName conFieldsAssign typeAssign) _) (Var reuseName (InfoConField conName nameNil):fieldValues) | conFieldsAssign == nameConFieldsAssign +genAppNormal (Var (TName conFieldsAssign typeAssign) _) (Var reuseName (InfoConField conName conRepr nameNil):fieldValues) | conFieldsAssign == nameConFieldsAssign = do tmp <- genVarName "con" let fieldNames = case splitFunScheme typeAssign of Just (_,_,args,_,_) -> tail (map fst args) _ -> failure ("Backend.C.FromCore: illegal conAssignFields type: " ++ show (pretty typeAssign)) - (decls, tmpDecl, assigns, result) <- genAssignFields tmp conName reuseName fieldNames fieldValues + (decls, tmpDecl, assigns, result) <- genAssignFields tmp conName conRepr reuseName fieldNames fieldValues return (decls ++ [tmpDecl] ++ assigns, result) -- special: cfield-hole -genAppNormal (Var unbox _) [App (Var cfieldHole _) []] | getName cfieldHole == nameCFieldHole && getName unbox == nameUnbox - = return ([],ppType (resultType (typeOf unbox)) <.> text "_hole()") +genAppNormal (Var unbox _) [App (Var cfieldHole _) []] | getName cfieldHole == nameCCtxHoleCreate && getName unbox == nameUnbox + = return ([], genHoleCall (resultType (typeOf unbox))) -- ppType (resultType (typeOf unbox)) <.> text "_hole()") -- special: cfield-of -genAppNormal (Var cfieldOf _) [App (Var box _) [App (Var dup _) [Var con _]], Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameCFieldOf && getName dup == nameDup +genAppNormal (Var cfieldOf _) [App (Var box _) [App (Var dup _) [Var con _]], Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf && getName dup == nameDup = do let doc = genFieldAddress con (readQualified conName) (readQualified fieldName) return ([],text "(kk_box_t*)" <.> parens doc) -genAppNormal (Var cfieldOf _) [App (Var box _) [Var con _], Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameCFieldOf +genAppNormal (Var cfieldOf _) [App (Var box _) [Var con _], Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf = do let drop = map (<.> semi) (genDupDropCall False (typeOf con) (ppName (getName con))) doc = genFieldAddress con (readQualified conName) (readQualified fieldName) return (drop,text "(kk_box_t*)" <.> parens doc) +-- special: cctx-set-context-path +genAppNormal (Var ctailSetContextPath _) [conExpr, Lit (LitString conName), Lit (LitString fieldName)] | getName ctailSetContextPath == nameCCtxSetCtxPath + = do (decl,conVar) <- genVarBinding conExpr + let doc = genCCtxSetContextPath conVar (readQualified conName) (readQualified fieldName) + return ([decl],doc) + -- add/sub small constant genAppNormal (Var add _) [arg, Lit (LitInt i)] | getName add == nameIntAdd && isSmallInt i -- arg + i = do (decls,argDocs) <- genInlineableExprs [arg] @@ -1817,8 +1958,8 @@ genAppNormal f args -> case f of -- constructor Con tname repr - -> let at = if (dataReprIsValue (conDataRepr repr) || isConAsJust repr) then [] else [text "kk_reuse_null"] - in return (decls,conCreateName (getName tname) <.> arguments (at ++ argDocs)) + -> let at = if (dataReprIsValue (conDataRepr repr) || isConAsJust repr) then [] else [text "kk_reuse_null"] + in return (decls,conCreateName (getName tname) <.> arguments (at ++ ppCtxPath repr tname (null argDocs) ++ argDocs)) -- call to known function Var tname _ | getName tname == nameAllocAt -> failure ("Backend.C.genApp.Var.allocat: " ++ show (f,args)) @@ -1835,25 +1976,48 @@ genAppNormal f args (map (ppType . snd) argTps) ++ [text "kk_context_t*"])) _ -> failure $ ("Backend.C.genAppNormal: expecting function type: " ++ show (pretty (typeOf f))) - return (fdecls ++ decls, text "kk_function_call" <.> tupled [cresTp,cargTps,fdoc,arguments (fdoc:argDocs)]) + return (fdecls ++ decls, text "kk_function_call" <.> arguments [cresTp,cargTps,fdoc,arguments (fdoc:argDocs)]) + +ppCtxPath :: ConRepr -> TName -> Bool -> [Doc] +ppCtxPath repr cname True = [] +ppCtxPath repr cname noArgs + = case conReprCtxPath repr of + Just (CtxNone) + -> [text "0"] + Just (CtxField fname) + -> [text "kk_field_index_of" <.> tupled [ + text "struct" <+> ppName (getName cname), ppName (unqualify (getName fname)) ]] + _ -> [] -- Assign fields to a constructor. Used in: genAppNormal on conAssignFields -genAssignFields :: Doc -> TName -> TName -> [Name] -> [Expr] -> Asm ([Doc], Doc, [Doc], Doc) -genAssignFields tmp conName reuseName fieldNames fieldValues +genAssignFields :: Doc -> TName -> ConRepr -> TName -> [Name] -> [Expr] -> Asm ([Doc], Doc, [Doc], Doc) +genAssignFields tmp conName conRepr reuseName fieldNames fieldValues = do (decls,fieldDocs) <- genExprs fieldValues let conTp = text "struct" <+> ppName (getName conName) <.> text "*" tmpDecl = conTp <+> tmp <+> text "=" <+> parens conTp <.> ppName (getName reuseName) <.> semi assigns = [tmp <.> text "->" <.> ppName fname <+> text "=" <+> fval <.> semi - | (fname,fval) <- zip fieldNames fieldDocs] - result = conBaseCastName (getName conName) <.> parens tmp - return (decls, tmpDecl, assigns, result) + | (fname,fval) <- zip fieldNames fieldDocs] + ctxpath = case conReprCtxPath conRepr of + Just (CtxField fname) + -> [text "kk_set_cpath" <.> tupled [ + text "struct" <+> ppName (getName conName), tmp, ppName (unqualify (getName fname))] + <.> semi] + _ -> [] + result = conBaseCastName (getName conName) <.> arguments [tmp] + return (decls, tmpDecl, ctxpath ++ assigns, result) genFieldAddress :: TName -> Name -> Name -> Doc genFieldAddress conVar conName fieldName - = parens (text "&" <.> conAsNameX (conName) <.> parens (ppName (getName conVar)) <.> text "->" <.> ppName (unqualify fieldName)) + = parens (text "&" <.> conAsNameX (conName) <.> arguments [ppName (getName conVar)] <.> text "->" <.> ppName (unqualify fieldName)) +genCCtxSetContextPath :: TName -> Name -> Name -> Doc +genCCtxSetContextPath conVar conName fieldName + = text "kk_cctx_setcp" <.> + arguments [-- conAsNameX conName, + ppName (getName conVar), + text "offsetof" <.> tupled [text "struct" <+> ppName conName, ppName (unqualify fieldName)]] genAppSpecial :: Expr -> [Expr] -> Asm (Maybe Doc) genAppSpecial f args @@ -1932,7 +2096,7 @@ genExprExternal tname formats [argDoc] | getName tname == nameBox || getName tna tp = case typeOf tname of TFun [(_,fromTp)] _ toTp -> if (isBox) then fromTp else toTp _ -> failure $ ("Backend.C.genExprExternal.unbox: expecting function type: " ++ show tname ++ ": " ++ show (pretty (typeOf tname))) - call = genBoxCall (if (isBox) then "box" else "unbox") False tp argDoc + call = if (isBox) then genBoxCall tp argDoc else genUnboxCallOwned tp argDoc in return ([], call) @@ -1996,12 +2160,14 @@ genExprExternal tname formats [argDoc] | getName tname == nameReuse in return ([], call) -- special case: cfield hole -genExprExternal tname formats [] | getName tname == nameCFieldHole - = return ([],ppType (resultType (typeOf tname)) <.> text "_hole()") +genExprExternal tname formats [] | getName tname == nameCCtxHoleCreate + = return ([], genHoleCall (resultType (typeOf tname))) -- ppType (resultType (typeOf tname)) <.> text "_hole()") +{- -- special case: cfield set genExprExternal tname formats [fieldDoc,argDoc] | getName tname == nameCFieldSet = return ([],text "*" <.> parens fieldDoc <+> text "=" <+> argDoc) +-} -- normal external genExprExternal tname formats argDocs0 @@ -2098,7 +2264,7 @@ isInlineableExpr expr Lit (LitString _)-> False -- C has no guarantee on argument evaluation so we only allow a select few operations to be inlined - App (Var v (InfoExternal _)) [] -> getName v `elem` [nameYielding,nameReuseNull,nameCFieldHole] + App (Var v (InfoExternal _)) [] -> getName v `elem` [nameYielding,nameReuseNull,nameCCtxHoleCreate] -- App (Var v (InfoExternal _)) [arg] | getName v `elem` [nameBox,nameDup,nameInt32] -> isInlineableExpr arg App (Var v _) [arg] | getName v `elem` [nameBox,nameInt32,nameReuse,nameReuseIsValid,nameIsUnique] -> isInlineableExpr arg @@ -2164,11 +2330,11 @@ instance Functor Asm where (x,st') -> (f x, st')) instance Applicative Asm where - pure = return - (<*>) = ap + pure x = Asm (\env st -> (x,st)) + (<*>) = ap instance Monad Asm where - return x = Asm (\env st -> (x,st)) + -- return = pure (Asm a) >>= f = Asm (\env st -> case a env st of (x,st1) -> case f x of Asm b -> b env st1) @@ -2193,7 +2359,7 @@ data Env = Env { moduleName :: Name -- | current modul , substEnv :: [(TName, Doc)] -- | substituting names , newtypes :: Newtypes , platform :: Platform - , inStatement :: Bool -- | for generating correct function declarations in strict mode + , eagerPatBind :: Bool } data Result = ResultReturn (Maybe TName) [TName] -- first field carries function name if not anonymous and second the arguments which are always known @@ -2291,6 +2457,11 @@ getPrettyEnv = do env <- getEnv return (prettyEnv env) +getEagerPatBind :: Asm Bool +getEagerPatBind + = do env <- getEnv + return (eagerPatBind env) + withTypeVars :: [TypeVar] -> Asm a -> Asm a withTypeVars vars asm = withEnv (\env -> env{ prettyEnv = Pretty.niceEnv (prettyEnv env) vars }) asm @@ -2299,15 +2470,6 @@ withNameSubstitutions :: [(TName, Doc)] -> Asm a -> Asm a withNameSubstitutions subs asm = withEnv (\env -> env{ substEnv = subs ++ substEnv env }) asm -withStatement :: Asm a -> Asm a -withStatement asm - = withEnv (\env -> env{ inStatement = True }) asm - -getInStatement :: Asm Bool -getInStatement - = do env <- getEnv - return (inStatement env) - getNewtypes :: Asm Newtypes getNewtypes = do env <- getEnv @@ -2445,7 +2607,7 @@ ppModName name encode :: Bool -> Name -> Doc encode isModule name = let s = asciiEncode isModule (show name) - in if (isReserved s) + in if (isReserved s || s == "" || isDigit (head s)) then text ("kkloc_" ++ s) else text s @@ -2592,3 +2754,7 @@ resultType tp = case splitFunScheme tp of Just (_,_,_,_,resTp) -> resTp _ -> failure ("Backend.C.FromCore.resultType: not a function type: " ++ show (pretty tp)) + +unzip4 xs = unzipx4 [] [] [] [] xs +unzipx4 acc1 acc2 acc3 acc4 [] = (reverse acc1, reverse acc2, reverse acc3, reverse acc4) +unzipx4 acc1 acc2 acc3 acc4 ((x,y,z,zz):xs) = unzipx4 (x:acc1) (y:acc2) (z:acc3) (zz:acc4) xs diff --git a/src/Backend/C/Parc.hs b/src/Backend/C/Parc.hs index 015bbef6d..4d77b1059 100644 --- a/src/Backend/C/Parc.hs +++ b/src/Backend/C/Parc.hs @@ -7,11 +7,20 @@ ----------------------------------------------------------------------------- {-# LANGUAGE NamedFieldPuns, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- precise automatic reference counting ------------------------------------------------------------------------------ +{---------------------------------------------------------------------------- +-- precise automatic reference counting (now called "Perceus") +-- See: https://www.microsoft.com/en-us/research/uploads/prod/2020/11/perceus-tr-v4.pdf -module Backend.C.Parc ( parcCore ) where +Notes: +- The monad has a borrowed and owned (multi-set) environment just like the paper +- The live variable set is a state +- To calculate the live variables we visit the expression tree _in reverse_ + (see the parcDefGroup, and parcExpr for let-bindings and applications for example) +- That still works with the borrowed and owned environments as those stay + the same in a scope. +----------------------------------------------------------------------------} + +module Backend.C.Parc ( parcCore, getDataDef', getDataInfo' ) where import Lib.Trace (trace) import Control.Monad @@ -39,8 +48,6 @@ import Core.CoreVar import Core.Pretty import Core.Borrowed -import Backend.C.ParcReuse( constructorSizeOf ) - -------------------------------------------------------------------------- -- Reference count transformation -------------------------------------------------------------------------- @@ -80,10 +87,10 @@ parcDef topLevel def -------------------------------------------------------------------------- parcTopLevelExpr :: DefSort -> Expr -> Parc Expr -parcTopLevelExpr (DefFun bs) expr +parcTopLevelExpr ds@(DefFun bs _) expr = case expr of TypeLam tpars body - -> TypeLam tpars <$> parcTopLevelExpr (DefFun bs) body + -> TypeLam tpars <$> parcTopLevelExpr ds body Lam pars eff body -> do let parsBs = zip pars $ bs ++ repeat Own let parsSet = S.fromList $ map fst $ filter (\x -> snd x == Own) parsBs @@ -155,7 +162,7 @@ parcExpr expr -> do name <- uniqueName "res" -- name the result return def{defName = name} _ -> return def - body1 <- ownedInScope (bv def1) $ parcExpr (Let dgs body) + body1 <- ownedInScope (S.singleton $ defTName def1) $ parcExpr (Let dgs body) def2 <- parcDef False def1 return $ makeLet [DefNonRec def2] body1 Let (DefRec _ : _) _ @@ -253,8 +260,8 @@ parcGuard scrutinees pats live (Guard test expr) test' <- withOwned S.empty $ parcExpr test return $ \liveInSomeBranch -> scoped pvs $ extendOwned ownedPvs $ extendShapes shapes $ do let dups = S.intersection ownedPvs liveInThisBranch - let drops = liveInSomeBranch \\ liveInThisBranch - Guard test' <$> parcGuardRC dups drops expr' + drops <- filterM isOwned (S.toList $ liveInSomeBranch \\ liveInThisBranch) + Guard test' <$> parcGuardRC dups (S.fromList drops) expr' type Dups = TNames type Drops = TNames @@ -452,10 +459,10 @@ inferShapes scrutineeNames pats where shapesOf :: TName -> Pattern -> Parc ShapeMap shapesOf parent pat = case pat of - PatCon{patConPatterns,patConName,patConRepr} + PatCon{patConPatterns,patConName,patConRepr,patConInfo} -> do ms <- mapM shapesChild patConPatterns - scan <- getConstructorScanFields patConName patConRepr - let m = M.unionsWith noDup ms + let scan = conReprScanCount patConRepr + m = M.unionsWith noDup ms shape = ShapeInfo (Just (tnamesFromList (map patName patConPatterns))) (Just (patConRepr,getName patConName)) (Just scan) return (M.insert parent shape m) @@ -580,18 +587,18 @@ getBoxForm' :: Platform -> Newtypes -> Type -> BoxForm getBoxForm' platform newtypes tp = -- trace ("getBoxForm' of " ++ show (pretty tp)) $ case getDataDef' newtypes tp of - Just (DataDefValue m 0) -- 0 scan fields, m is size in bytes of raw fields + Just (DataDefValue (ValueRepr m 0 _)) -- 0 scan fields, m is size in bytes of raw fields -> -- trace " 0 scan fields" $ case extractDataDefType tp of Just name - | name `elem` [nameTpInt, nameTpCField] || + | name `elem` [nameTpInt, nameTpFieldAddr] || ((name `elem` [nameTpInt8, nameTpInt16, nameTpFloat16]) && sizePtr platform > 2) || ((name `elem` [nameTpChar, nameTpInt32, nameTpFloat32]) && sizePtr platform > 4) -> BoxIdentity _ -> if m < sizePtr platform -- for example, `bool`, but not `int64` then BoxIdentity else BoxRaw - Just (DataDefValue _ _) + Just (DataDefValue{}) -> BoxValue Just _ -> BoxIdentity @@ -625,15 +632,15 @@ needsDupDrop :: Type -> Parc Bool needsDupDrop tp = do dd <- getDataDef tp return $ case dd of - (DataDefValue _ 0) -> False - _ -> True + (DataDefValue vr) | valueReprIsRaw vr -> False + _ -> True isValueType :: Type -> Parc Bool isValueType tp = do dd <- getDataDef tp return $ case dd of - (DataDefValue _ _) -> True - _ -> False + (DataDefValue{}) -> True + _ -> False data ValueForm = ValueAllRaw -- just bits @@ -643,10 +650,10 @@ data ValueForm getValueForm' :: Newtypes -> Type -> Maybe ValueForm getValueForm' newtypes tp = case getDataDef' newtypes tp of - Just (DataDefValue _ 0) -> Just ValueAllRaw - Just (DataDefValue 0 1) -> Just ValueOneScan - Just (DataDefValue _ _) -> Just ValueOther - _ -> Nothing + Just (DataDefValue (ValueRepr _ 0 _)) -> Just ValueAllRaw + Just (DataDefValue (ValueRepr 0 1 _)) -> Just ValueOneScan + Just (DataDefValue _) -> Just ValueOther + _ -> Nothing getValueForm :: Type -> Parc (Maybe ValueForm) getValueForm tp = (`getValueForm'` tp) <$> getNewtypes @@ -682,10 +689,10 @@ genDupDrop isDup tname mbConRepr mbScanCount in case mbDi of Just di -> case (dataInfoDef di, dataInfoConstrs di, snd (getDataRepr di)) of (DataDefNormal, [conInfo], [conRepr]) -- data with just one constructor - -> do scan <- getConstructorScanFields (TName (conInfoName conInfo) (conInfoType conInfo)) conRepr + -> do let scan = conReprScanCount conRepr -- parcTrace $ " add scan fields: " ++ show scan ++ ", " ++ show tname return (Just (dupDropFun isDup tp (Just (conRepr,conInfoName conInfo)) (Just scan) (Var tname InfoNone))) - (DataDefValue _ 0, _, _) + (DataDefValue vr, _, _) | valueReprIsRaw vr -> do -- parcTrace $ (" value with no scan fields: " ++ show di ++ ", " ++ show tname) return Nothing -- value with no scan fields _ -> do -- parcTrace $ " dup/drop(1), " ++ show tname @@ -826,16 +833,6 @@ getPlatform :: Parc Platform getPlatform = platform <$> getEnv -getConstructorScanFields :: TName -> ConRepr -> Parc Int -getConstructorScanFields conName conRepr - = do platform <- getPlatform - newtypes <- getNewtypes - let (size,scan) = (constructorSizeOf platform newtypes conName conRepr) - -- parcTrace $ "get size " ++ show conName ++ ": " ++ show (size,scan) ++ ", " ++ show conRepr - return scan - --- - getOwned :: Parc Owned getOwned = owned <$> getEnv diff --git a/src/Backend/C/ParcReuse.hs b/src/Backend/C/ParcReuse.hs index 99e3a347e..11823573e 100644 --- a/src/Backend/C/ParcReuse.hs +++ b/src/Backend/C/ParcReuse.hs @@ -11,10 +11,7 @@ -- constructor reuse analysis ----------------------------------------------------------------------------- -module Backend.C.ParcReuse ( parcReuseCore, - orderConFieldsEx, newtypesDataDefRepr, hasTagField, - constructorSizeOf - ) where +module Backend.C.ParcReuse ( parcReuseCore, getFixedDataAllocSize ) where import Lib.Trace (trace) import Control.Monad @@ -22,6 +19,7 @@ import Control.Monad.Reader import Control.Monad.State import Data.Char import Data.Maybe (catMaybes, maybeToList) +import Data.List (isSuffixOf) import qualified Data.Set as S import qualified Data.Map as Map import qualified Data.IntMap as M @@ -113,7 +111,7 @@ ruLam :: [TName] -> Effect -> Expr -> Reuse Expr ruLam pars eff body = fmap (Lam pars eff) $ withNone $ do forM_ pars $ \p -> do - msize <- getRuConSize (typeOf p) + msize <- getRuFixedDataAllocSize (typeOf p) case msize of Just (size, scan) -> addDeconstructed (p, Nothing, size, scan) Nothing -> return () @@ -238,13 +236,14 @@ ruPattern varName pat@PatCon{patConName,patConPatterns,patConRepr,patTypeArgs,pa else do newtypes <- getNewtypes platform <- getPlatform -- use type scheme of con, not the instantiated type, to calculate the correct size - let (size, scan) = constructorSizeOf platform newtypes (TName (conInfoName ci) (conInfoType ci)) patConRepr + let (size,scan) = -- constructorSizeOf platform newtypes (TName (conInfoName ci) (conInfoType ci)) patConRepr + conReprAllocSizeScan platform patConRepr if size > 0 then do -- ruTrace $ "add for reuse: " ++ show (getName tname) ++ ": " ++ show size return ((varName, Just pat, size, scan):reuses) else return reuses ruPattern varName _ - = do msize <- getRuConSize (typeOf varName) + = do msize <- getRuFixedDataAllocSize (typeOf varName) case msize of Just (size, scan) -> return [(varName, Nothing, size, scan)] Nothing -> return [] @@ -263,15 +262,18 @@ ruGuard (Guard test expr) -- expects patAdded in depth-order ruTryReuseCon :: TName -> ConRepr -> Expr -> Reuse Expr ruTryReuseCon cname repr conApp | isConAsJust repr -- never try to reuse a Just-like constructor = return conApp +ruTryReuseCon cname repr conApp | "_noreuse" `isSuffixOf` nameId (conTypeName repr) + = return conApp -- special case to allow benchmarking the effect of reuse analysis ruTryReuseCon cname repr conApp - = do newtypes <- getNewtypes + = do -- newtypes <- getNewtypes platform <- getPlatform - let (size,_) = constructorSizeOf platform newtypes cname repr + let size = conReprAllocSize platform repr available <- getAvailable -- ruTrace $ "try reuse: " ++ show (getName cname) ++ ": " ++ show size case M.lookup size available of - Just (rinfo0:rinfos0) - -> do let (rinfo,rinfos) = pick cname rinfo0 rinfos0 + Just (rinfo:rinfos) + -> do -- let (rinfo,rinfos) = pick cname rinfo0 rinfos0 + -- Picking can prevent reuse in FIP programs, disabled for now. setAvailable (M.insert size rinfos available) markReused (reuseName rinfo) return (genAllocAt rinfo conApp) @@ -558,6 +560,15 @@ isolateGetReused action setReused r0 return (x,r1) +{- +getConstructorSize :: TName -> ConRepr -> Reuse Int +getConstructorSize conName conRepr + = do newtypes <- getNewtypes + platform <- getPlatform + let (size,_) = constructorSizeOfByName platform newtypes (getName conName) conRepr + return size +-} + -------------------------------------------------------------------------- -- Tracing -------------------------------------------------------------------------- @@ -577,21 +588,40 @@ ruTrace msg -- | If all constructors of a type have the same shape, -- return the byte size and number of scan fields. -getRuConSize :: Type -> Reuse (Maybe (Int, Int)) -getRuConSize dataType +getRuFixedDataAllocSize :: Type -> Reuse (Maybe (Int, Int)) +getRuFixedDataAllocSize dataType = do newtypes <- getNewtypes platform <- getPlatform - let mdataName = extractDataName dataType - let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName - case mdataInfo of - Just dataInfo - -> do let (dataRepr, _) = getDataRepr dataInfo - let cis = dataInfoConstrs dataInfo - let sizes = map (constructorSize platform newtypes dataRepr . map snd . conInfoParams) cis - case sizes of - (s:ss) | all (==s) ss -> pure $ Just s - _ -> pure Nothing - _ -> pure Nothing + pure $ getFixedDataAllocSize platform newtypes dataType + +-- | If all constructors of a type have the same shape, +-- return the byte size and number of scan fields. +getFixedDataAllocSize :: Platform -> Newtypes -> Type -> Maybe (Int, Int) +getFixedDataAllocSize platform newtypes dataType + = let mdataName = extractDataName dataType in + if maybe False (\nm -> "_noreuse" `isSuffixOf` nameId nm) mdataName + then Nothing else + let mdataInfo = (`newtypesLookupAny` newtypes) =<< mdataName in + case mdataInfo of + Just dataInfo + -> let ddef = dataInfoDef dataInfo + in if dataDefIsValue ddef + then Nothing + else let cis = dataInfoConstrs dataInfo + sizeScanCounts = map (valueReprSizeScan platform . conInfoValueRepr) cis + in case sizeScanCounts of + (ss:sss) | all (==ss) sss -> Just ss + _ -> Nothing + {- + in case ddef of + DataDefValue vrepr + -> let cis = dataInfoConstrs dataInfo + sizes = map (conInfoSize platform) cis + in case sizes of + (s:ss) | all (==s) ss -> Just (valueReprSize platform vrepr, valueReprScanCount vrepr) + _ -> Nothing + _ -> Nothing -} + _ -> Nothing where extractDataName :: Type -> Maybe Name extractDataName tp @@ -601,13 +631,25 @@ getRuConSize dataType _ -> Nothing +{- + -- return the allocated size of a constructor. Return 0 for value types or singletons -constructorSizeOf :: Platform -> Newtypes -> TName -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) -constructorSizeOf platform newtypes conName conRepr +constructorSizeOf :: Platform -> Newtypes -> ConInfo -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) +constructorSizeOf platform newtypes conInfo conRepr + = constructorSizeOfX platform newtypes (TName (conInfoName conInfo) (conInfoType conInfo)) conRepr + +-- return the allocated size of a constructor. Return 0 for value types or singletons +-- note: expects the general type of the constructor in TName -- not an instantiated type! +constructorSizeOfX :: Platform -> Newtypes -> TName -> ConRepr -> (Int {- byte size -}, Int {- scan fields -}) +constructorSizeOfX _ _ _ repr | "_noreuse" `isSuffixOf` nameId (conTypeName repr) + = (0,0) -- special case to allow benchmarking the effect of reuse analysis +constructorSizeOfX platform newtypes conName conRepr = let dataRepr = conDataRepr conRepr in case splitFunScheme (typeOf conName) of Just (_,_,tpars,_,_) - -> constructorSize platform newtypes dataRepr (map snd tpars) + -> let (size,scan) = constructorSize platform newtypes dataRepr (map snd tpars) + in -- trace ("constructor: " ++ show conName ++ ": size: " ++ show size ++ ", scan: " ++ show scan ++ ", " ++ show tpars) $ + (size,scan) _ -> -- trace ("constructor not a function: " ++ show conName ++ ": " ++ show (pretty (typeOf conName))) $ (0,0) @@ -628,7 +670,7 @@ constructorSize platform newtypes dataRepr paramTypes -- return the ordered fields, the byte size of the allocation, and the scan count (including tags) orderConFieldsEx :: Platform -> Newtypes -> Bool -> [(Name,Type)] -> ([(Name,Type)],Int,Int) orderConFieldsEx platform newtypes isOpen fields - = visit ([],[],[],0) fields + = visit ([],[],[],0) fields where visit (rraw, rmixed, rscan, scanCount0) [] = if (length rmixed > 1) @@ -642,15 +684,15 @@ orderConFieldsEx platform newtypes isOpen fields visit (rraw,rmixed,rscan,scanCount) (field@(name,tp) : fs) = let mDataDefRepr = newtypesDataDefRepr newtypes tp in case mDataDefRepr of - Just (DataDefValue raw scan, dataRepr) - -> let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors + Just (DataDefValue (ValueRepr raw scan alignment), dataRepr) + -> -- let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors if (raw > 0 && scan > 0) then -- mixed raw/scan: put it at the head of the raw fields (there should be only one of these as checked in Kind/Infer) -- but we count them to be sure (and for function data) - visit (rraw, (field,raw):rmixed, rscan, scanCount + scan + extra) fs + visit (rraw, (field,raw):rmixed, rscan, scanCount + scan) fs else if (raw > 0) then visit (insertRaw field raw rraw, rmixed, rscan, scanCount) fs - else visit (rraw, rmixed, field:rscan, scanCount + scan + extra) fs + else visit (rraw, rmixed, field:rscan, scanCount + scan) fs _ -> visit (rraw, rmixed, field:rscan, scanCount + 1) fs -- insert raw fields in order of size so they align to the smallest total size in a datatype @@ -686,3 +728,5 @@ hasTagField :: DataRepr -> Bool hasTagField DataStruct = True hasTagField DataStructAsMaybe = True hasTagField rep = False + +-} \ No newline at end of file diff --git a/src/Backend/C/ParcReuseSpec.hs b/src/Backend/C/ParcReuseSpec.hs index d816e18a9..372e77d7f 100644 --- a/src/Backend/C/ParcReuseSpec.hs +++ b/src/Backend/C/ParcReuseSpec.hs @@ -131,7 +131,7 @@ ruSpecialize reuseName info conApp specialize = oldTagBenefit + length (filter isMatch matches) >= 1 + ((1 + length args) `div` 4) case (mci, specialize) of (Just ci, True) - -> Just <$> ruSpecCon reuseName cname ci needsTag (conTag repr) (typeOf conApp) (App con) matches + -> Just <$> ruSpecCon reuseName cname repr ci needsTag (conTag repr) (typeOf conApp) (App con) matches _ -> return Nothing Nothing -> return Nothing _ -> return Nothing @@ -143,13 +143,13 @@ ruSpecialize reuseName info conApp -- | Move dups before the allocation and emit: -- if(reuseName != NULL) { set tag and fields } -- else { allocate constructor without reuse } -ruSpecCon :: TName -> TName -> ConInfo -> Bool -> Int -> Type -> ([Expr] -> Expr) -> [Match] -> Reuse Expr -ruSpecCon reuseName conName conInfo needsTag tag resultType makeConApp matches +ruSpecCon :: TName -> TName -> ConRepr -> ConInfo -> Bool -> Int -> Type -> ([Expr] -> Expr) -> [Match] -> Reuse Expr +ruSpecCon reuseName conName conRepr conInfo needsTag tag resultType makeConApp matches = do (defss, assigns) <- unzip <$> mapM ruToAssign matches let fields = map fst (conInfoParams conInfo) nonMatching = [(name,expr) | (name,(expr,isMatch)) <- zip fields assigns, not isMatch] - reuseExpr = if needsTag then genConTagFieldsAssign resultType conName reuseName tag nonMatching - else genConFieldsAssign resultType conName reuseName nonMatching + reuseExpr = if needsTag then genConTagFieldsAssign resultType conName conRepr reuseName tag nonMatching + else genConFieldsAssign resultType conName conRepr reuseName nonMatching specExpr = makeIfExpr (genReuseIsValid reuseName) reuseExpr (makeConApp (map fst assigns)) return (makeLet (concat defss) specExpr) @@ -199,20 +199,20 @@ genReuseIsValid reuseName -- genConFieldsAssign tp conName reuseName [(field1,expr1)...(fieldN,exprN)] -- generates: c = (conName*)reuseName; c->field1 := expr1; ... ; c->fieldN := exprN; (tp*)(c) -genConTagFieldsAssign :: Type -> TName -> TName -> Int -> [(Name,Expr)] -> Expr -genConTagFieldsAssign resultType conName reuseName tag fieldExprs +genConTagFieldsAssign :: Type -> TName -> ConRepr -> TName -> Int -> [(Name,Expr)] -> Expr +genConTagFieldsAssign resultType conName conRepr reuseName tag fieldExprs = App (Var (TName nameConTagFieldsAssign typeConFieldsAssign) (InfoArity 0 (length fieldExprs + 1))) - ([Var reuseName (InfoConField conName nameNil), Var (TName (newName (show tag)) typeUnit) InfoNone] ++ map snd fieldExprs) + ([Var reuseName (InfoConField conName conRepr nameNil), Var (TName (newName (show tag)) typeUnit) InfoNone] ++ map snd fieldExprs) where fieldTypes = [(name,typeOf expr) | (name,expr) <- fieldExprs] typeConFieldsAssign = TFun ([(nameNil,typeOf reuseName), (nameNil, typeUnit)] ++ fieldTypes) typeTotal resultType -- genConTagFieldsAssign tp conName reuseName [(field1,expr1)...(fieldN,exprN)] -- generates: c = (conName*)reuseName; c->field1 := expr1; ... ; c->fieldN := exprN; (tp*)(c) -genConFieldsAssign :: Type -> TName -> TName -> [(Name,Expr)] -> Expr -genConFieldsAssign resultType conName reuseName fieldExprs +genConFieldsAssign :: Type -> TName -> ConRepr -> TName -> [(Name,Expr)] -> Expr +genConFieldsAssign resultType conName conRepr reuseName fieldExprs = App (Var (TName nameConFieldsAssign typeConFieldsAssign) (InfoArity 0 (length fieldExprs + 1))) - (Var reuseName (InfoConField conName nameNil) : map snd fieldExprs) + (Var reuseName (InfoConField conName conRepr nameNil) : map snd fieldExprs) where fieldTypes = [(name,typeOf expr) | (name,expr) <- fieldExprs] typeConFieldsAssign = TFun ((nameNil,typeOf reuseName) : fieldTypes) typeTotal resultType diff --git a/src/Backend/CSharp/FromCore.hs b/src/Backend/CSharp/FromCore.hs index 410a6142b..f7e99a5e8 100644 --- a/src/Backend/CSharp/FromCore.hs +++ b/src/Backend/CSharp/FromCore.hs @@ -202,18 +202,18 @@ genTypeDef (Data info isExtend) genConstructor :: DataInfo -> DataRepr -> (ConInfo,ConRepr) -> Asm () genConstructor info dataRepr (con,conRepr) = case conRepr of - ConEnum _ _ _ + ConEnum{} -> return () - ConSingleton typeName _ _ + ConSingleton{conTypeName=typeName} -> assertion ("CSharp.FromCore.genTypeDef: singleton constructor with existentials?") (null (conInfoExists con)) $ conSingleton typeName - ConAsCons typeName _ nilName _ + ConAsCons typeName _ _ nilName _ _ -> -- merge it into the type class itself do ctx <- getModule putLn (vcat (map (ppConField ctx) (conInfoParams con) ++ ppConConstructor ctx con conRepr [])) - ConSingle typeName _ _ + ConSingle{conTypeName=typeName} -> -- merge it into the type class itself do ctx <- getModule let docs = map (ppConField ctx) (conInfoParams con) ++ ppConConstructor ctx con conRepr [] @@ -221,10 +221,10 @@ genConstructor info dataRepr (con,conRepr) = then return () else putLn (vcat docs) - ConStruct typeName _ _ + ConStruct{conTypeName=typeName} -> conStruct typeName - ConIso typeName _ _ + ConIso{conTypeName=typeName} -> conStruct typeName _ -> onTopLevel $ @@ -302,18 +302,18 @@ ppConConstructorEx ctx con conRepr conParams defaults then [] else [text "public" <+> (case conRepr of - ConAsCons typeName _ nilName _ -> ppDefName (typeClassName typeName) - ConSingle typeName _ _ -> ppDefName (typeClassName typeName) - ConStruct typeName _ _ -> ppDefName (typeClassName typeName) - ConIso typeName _ _ -> ppDefName (typeClassName typeName) - _ -> ppDefName (conClassName (conInfoName con))) <.> + ConAsCons typeName _ _ nilName _ _ -> ppDefName (typeClassName typeName) + ConSingle{conTypeName=typeName} -> ppDefName (typeClassName typeName) + ConStruct{conTypeName=typeName} -> ppDefName (typeClassName typeName) + ConIso {conTypeName=typeName} -> ppDefName (typeClassName typeName) + _ -> ppDefName (conClassName (conInfoName con))) <.> tupled (map ppParam (conInfoParams con)) <+> (case conRepr of - ConNormal typeName _ _ -> text ":" <+> text "base" <.> parens (ppTag ctx typeName (conInfoName con)) <.> space + ConNormal{conTypeName=typeName} -> text ":" <+> text "base" <.> parens (ppTag ctx typeName (conInfoName con)) <.> space _ -> empty) <.> block (linebreak <.> vcat ( (case conRepr of - ConStruct typeName _ _ -> [text "this." <.> ppTagName <+> text "=" <+> ppTag ctx typeName (conInfoName con) <.> semi] + ConStruct{conTypeName=typeName} -> [text "this." <.> ppTagName <+> text "=" <+> ppTag ctx typeName (conInfoName con) <.> semi] _ -> []) ++ map ppAssignConField conParams ++ map (ppAssignDefault ctx) defaults @@ -743,28 +743,28 @@ genCon tname repr targs args ctx <- getModule result $ hang 2 $ -- cast $ case repr of - ConEnum _ _ _ + ConEnum{} -> assertion "genCon: ConEnum has type args or args?" (null targs && null args) $ ppConEnum ctx tname - ConSingleton typeName _ _ + ConSingleton{conTypeName=typeName} -> ppConSingleton ctx typeName tname targs - ConStruct typeName _ _ | null args + ConStruct{conTypeName=typeName} | null args -> ppConSingleton ctx typeName tname targs - ConStruct typeName _ _ + ConStruct{conTypeName=typeName} -> text "new" <+> ppQName ctx (typeClassName typeName) <.> ppTypeArgs ctx targs tupled ({- ppTag ctx typeName (getName tname) : -} argDocs) - ConIso typeName _ _ + ConIso{conTypeName=typeName} -> text "new" <+> ppQName ctx (typeClassName typeName) <.> ppTypeArgs ctx targs tupled ({- ppTag ctx typeName (getName tname) : -} argDocs) _ -> text "new" <+> (case repr of - ConAsCons typeName _ _ _ + ConAsCons{conTypeName=typeName} -> ppQName ctx (typeClassName typeName) - ConSingle typeName _ _ + ConSingle{conTypeName=typeName} -> ppQName ctx (typeClassName typeName) _ -> ppQName ctx (conClassName (getName tname))) <.> (ppTypeArgs ctx targs) @@ -1056,10 +1056,10 @@ genTag (exprDoc,patterns) -- putLn (text "int" <+> ppDefName local <+> text "=" <+> exprDoc <.> text "." <.> ppTagName <.> semi) return (Just (exprDoc <.> text "." <.> ppTagName)) where - isConMatch (PatCon _ _ (ConNormal _ _ _) _ _ _ _ _) = True - isConMatch (PatCon _ _ (ConStruct _ _ _) _ _ _ _ _) = True - isConMatch (PatCon _ _ (ConIso _ _ _) _ _ _ _ _) = True - isConMatch _ = False + isConMatch (PatCon _ _ (ConNormal{}) _ _ _ _ _) = True + isConMatch (PatCon _ _ (ConStruct{}) _ _ _ _ _) = True + isConMatch (PatCon _ _ (ConIso{}) _ _ _ _ _) = True + isConMatch _ = False genBranch :: [Maybe Doc] -> [Doc] -> Bool -> Branch -> Asm () genBranch mbTagDocs exprDocs doTest branch@(Branch patterns [g@(Guard guard expr)]) -- TODO: adapt for multiple guards! @@ -1150,13 +1150,13 @@ genPatternTest doTest (mbTagDoc,exprDoc,pattern) PatCon tname patterns repr targs exists tres info skip -- TODO: use skip -> do ctx <- getModule case repr of - ConEnum _ _ _ + ConEnum{} -> assertion "CSharp.FromCore.ppPatternTest.enum with patterns?" (null patterns) $ return [(test [exprDoc <+> text "==" <+> ppConEnum ctx tname],[],[],[])] - ConSingleton typeName _ _ + ConSingleton typeName _ _ _ -> assertion "CSharp.FromCore.ppPatternTest.singleton with patterns?" (null patterns) $ return [(test [exprDoc <+> text "==" <+> ppConSingleton ctx typeName tname tpars],[],[],[])] - ConSingle typeName _ _ + ConSingle typeName _ _ _ _ -> -- assertion ("CSharp.FromCore.ppPatternTest.single with test? ") (doTest == False) $ -- note: the assertion can happen when a nested singleton is tested do -- generate local for the test result @@ -1166,20 +1166,20 @@ genPatternTest doTest (mbTagDoc,exprDoc,pattern) return [([] -- test [exprDoc <+> text "!=" <+> ppConSingleton ctx typeName (TName nilName (typeOf tname)) targs] ,[],next,[])] - ConAsCons typeName _ nilName _ + ConAsCons typeName _ _ nilName _ _ -> do let next = genNextPatterns (exprDoc) (typeOf tname) patterns return [(test [exprDoc <+> text "!=" <+> ppConSingleton ctx typeName (TName nilName (typeOf tname)) tpars] ,[],next,[])] - ConAsJust typeName _ _ _ + ConAsJust typeName _ _ _ _ -> testStruct typeName - ConStruct typeName _ _ + ConStruct typeName _ _ _ -> testStruct typeName - ConIso typeName _ _ + ConIso typeName _ _ _ -> testStruct typeName - ConNormal typeName _ _ + ConNormal typeName _ _ _ _ -> conTest ctx typeName exists -- TODO: use tags if available - ConOpen typeName _ + ConOpen{conTypeName=typeName} -> conTest ctx typeName exists where testStruct typeName @@ -1524,11 +1524,11 @@ instance Functor Asm where fmap f (Asm a) = Asm (\env st -> case a env st of (x,st') -> (f x, st')) instance Applicative Asm where - pure = return + pure x = Asm (\env st -> (x,st)) (<*>) = ap instance Monad Asm where - return x = Asm (\env st -> (x,st)) + -- return = pure (Asm a) >>= f = Asm (\env st -> case a env st of (x,st1) -> case f x of Asm b -> b env st1) diff --git a/src/Backend/JavaScript/FromCore.hs b/src/Backend/JavaScript/FromCore.hs index 6c4c542f3..717f3ecdc 100644 --- a/src/Backend/JavaScript/FromCore.hs +++ b/src/Backend/JavaScript/FromCore.hs @@ -275,13 +275,13 @@ genTypeDef (Data info isExtend) -- special ConEnum{} -> constdecl <+> name <+> text "=" <+> int (conTag repr) <.> semi <+> linecomment (Pretty.ppType penv (conInfoType c)) - ConSingleton _ _ _ | conInfoName c == nameOptionalNone + ConSingleton{} | conInfoName c == nameOptionalNone -> singletonValue "undefined" - ConSingleton _ DataStructAsMaybe _ + ConSingleton _ DataStructAsMaybe _ _ -> singletonValue "null" - ConSingleton _ DataAsMaybe _ + ConSingleton _ DataAsMaybe _ _ -> singletonValue "null" - ConSingleton _ DataAsList _ + ConSingleton _ DataAsList _ _ -> singletonValue "null" -- tagless ConIso{} -> genConstr penv c repr name args [] @@ -589,18 +589,18 @@ genMatch result scrutinees branches | otherwise -> case repr of -- special - ConEnum _ _ tag + ConEnum _ _ _ tag -> [debugWrap "genTest: enum" $ scrutinee <+> text "===" <+> int tag] - ConSingleton _ _ _ + ConSingleton{} | getName tn == nameOptionalNone -> [debugWrap "genTest: optional none" $ scrutinee <+> text "=== undefined"] - ConSingleton _ DataStructAsMaybe _ + ConSingleton _ DataStructAsMaybe _ _ -> [debugWrap "genTest: maybe like nothing" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] - ConSingleton _ DataAsMaybe _ + ConSingleton _ DataAsMaybe _ _ -> [debugWrap "genTest: maybe like nothing" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] - ConSingleton _ DataAsList _ + ConSingleton _ DataAsList _ _ -> [debugWrap "genTest: list like nil" $ scrutinee <+> text "=== null"] -- <+> ppName (getName tn)] - ConSingleton _ _ tag + ConSingleton{conTag=tag} -> [debugWrap "genTest: singleton" $ scrutinee <.> dot <.> tagField <+> text "===" <+> int tag] ConSingle{} -- always succeeds, but need to test the fields -> concatMap @@ -698,10 +698,10 @@ genExpr expr App (Var tname _) [Lit (LitInt i)] | getName tname == nameInt64 && isSmallInt i -> return (empty, pretty i <.> text "n") - -- special: cfield-of - App (TypeApp (Var cfieldOf _) [_]) [Var con _, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameCFieldOf + -- special: .cctx-field-addr-of: create a tuple with the object and the field name as a string + App (TypeApp (Var cfieldOf _) [_]) [Var con _, Lit (LitString conName), Lit (LitString fieldName)] | getName cfieldOf == nameFieldAddrOf -> do conDoc <- genTName con - return (empty,text "{value:" <+> conDoc <.> text ", field: \"" <.> ppName (unqualify (readQualified fieldName)) <.> text "\"}") + return (empty,text "{obj:" <+> conDoc <.> text ", field_name: \"" <.> ppName (unqualify (readQualified fieldName)) <.> text "\"}") App f args -> {- case splitFunScheme (typeOf f) of @@ -910,14 +910,16 @@ genExprExternal tname formats argDocs0 <.> text "()" in return ([],try) --- special case: cfield-hole +-- special case: .cctx-hole-create genExprExternalPrim :: TName -> [(Target,String)] -> [Doc] -> Asm ([Doc],Doc) -genExprExternalPrim tname formats [] | getName tname == nameCFieldHole +genExprExternalPrim tname formats [] | getName tname == nameCCtxHoleCreate = return ([],text "undefined") +{- -- special case: cfield-set (field is implemented as {value:, field:}) genExprExternalPrim tname formats [accDoc,resDoc] | getName tname == nameCFieldSet = return ([], tupled [accDoc <.> text ".value[" <.> accDoc <.> text ".field] =" <+> resDoc, text "$std_core_types._Unit_"]) +-} -- normal external genExprExternalPrim tname formats argDocs0 @@ -1085,11 +1087,11 @@ instance Functor Asm where (x,st') -> (f x, st')) instance Applicative Asm where - pure = return - (<*>) = ap + pure x = Asm (\env st -> (x,st)) + (<*>) = ap instance Monad Asm where - return x = Asm (\env st -> (x,st)) + -- return = pure (Asm a) >>= f = Asm (\env st -> case a env st of (x,st1) -> case f x of Asm b -> b env st1) diff --git a/src/Common/Error.hs b/src/Common/Error.hs index ba32e5397..204af4a0b 100644 --- a/src/Common/Error.hs +++ b/src/Common/Error.hs @@ -10,7 +10,7 @@ -} ----------------------------------------------------------------------------- module Common.Error( Error, ErrorMessage(..), errorMsg, ok - , catchError, checkError, warningMsg, addWarnings + , catchError, checkError, warningMsg, addWarnings, ignoreWarnings , ppErrorMessage, errorWarning ) where import Control.Monad @@ -91,6 +91,10 @@ errorMerge err1 err2 unwarn (ErrorWarning warnings msg) = (warnings, msg) unwarn msg = ([],msg) +ignoreWarnings :: Error a -> Error a +ignoreWarnings (Error (ErrorWarning _ err) _) = Error err [] +ignoreWarnings (Error err _) = Error err [] +ignoreWarnings (Ok x _) = Ok x [] {-------------------------------------------------------------------------- pretty @@ -131,11 +135,11 @@ instance Functor Error where Error msg w -> Error msg w instance Applicative Error where - pure = return + pure x = Ok x [] (<*>) = ap instance Monad Error where - return x = Ok x [] + -- return = pure e >>= f = case e of Ok x w -> addWarnings w (f x) Error msg w -> Error msg w diff --git a/src/Common/Name.hs b/src/Common/Name.hs index 4502b0c8e..642036d12 100644 --- a/src/Common/Name.hs +++ b/src/Common/Name.hs @@ -24,6 +24,7 @@ module Common.Name , qualify, unqualify, isQualified, qualifier , nameId, nameModule + , newPaddingName, isPaddingName, isCCtxName , newFieldName, isFieldName, isWildcard , newHiddenExternalName, isHiddenExternalName , newHiddenName, isHiddenName, hiddenNameStartsWith @@ -52,7 +53,7 @@ import Lib.Trace( trace ) import Lib.PPrint (Pretty(pretty), text ) import Data.Char(isUpper,toLower,toUpper,isAlphaNum,isDigit,isAlpha) import Common.Failure(failure) -import Common.File( joinPaths, splitOn, endsWith, startsWith ) +import Common.File( joinPaths, splitOn, endsWith, startsWith, isPathSep ) import Common.Range( rangeStart, posLine, posColumn ) import Data.List(intersperse) @@ -140,7 +141,7 @@ instance Show Name where pre = if null m then "" else m ++ "/" in pre ++ case mid of (c:cs) -- | any (\c -> c `elem` ".([])") mid -> "(" ++ n ++ ")" - | not (isAlpha c || c=='_' || c=='(' || c== '.') -> "(" ++ n ++ ")" + | not (isAlphaNum c || c=='_' || c=='(' || c== '.') -> "(" ++ n ++ ")" _ -> n @@ -312,18 +313,39 @@ toUniqueName i name insert (c:cs) | c `elem` "'?" = c : insert cs insert cs = reverse (show i) ++ cs +toHiddenUniqueName :: Int -> String -> Name -> Name +toHiddenUniqueName i "" name + = prepend "." (toUniqueName i name) +toHiddenUniqueName i s name + = makeHiddenName (s ++ show i) xname + where + c = (head (nameId name)) + xname = if (isAlpha c || c=='.' ) then name else newQualified (nameModule name) ("op") + + +newPaddingName i + = newHiddenName ("padding" ++ show i) + +isPaddingName name + = -- hiddenNameStartsWith name "padding" + nameId name `startsWith` (".padding") + +isCCtxName name + = -- hiddenNameStartsWith name "padding" + nameId name `startsWith` (".cctx") + newFieldName i = newHiddenName ("field" ++ show i) isFieldName name - = isHiddenName name + = isHiddenName name -- hiddenNameStartsWith name "field" newImplicitTypeVarName i = newHiddenName ("t" ++ show i) -isImplicitTypeVarName name +isImplicitTypeVarName name = isHiddenName name @@ -456,11 +478,6 @@ postpend s cname in newQualified (nameModule name) (nameId name ++ s ++ post) -toHiddenUniqueName :: Int -> String -> Name -> Name -toHiddenUniqueName i s name - = makeHiddenName (s ++ show i) xname - where - xname = if (isAlpha (head (nameId name))) then name else newQualified (nameModule name) ("op") canonicalName :: Int -> Name -> Name canonicalName n name @@ -512,9 +529,13 @@ moduleNameToPath :: Name -> FilePath moduleNameToPath name = asciiEncode True (show name) + pathToModuleName :: FilePath -> Name pathToModuleName path - = newName $ dropWhile (\c -> c `elem` "_./") $ decode path + = newName $ dropWhile (\c -> c `elem` "_./") $ + decode $ + map (\c -> if isPathSep c then '/' else c) $ + path where -- TODO: do proper decoding decode s diff --git a/src/Common/NamePrim.hs b/src/Common/NamePrim.hs index be7e756c2..392dabcde 100644 --- a/src/Common/NamePrim.hs +++ b/src/Common/NamePrim.hs @@ -70,14 +70,30 @@ module Common.NamePrim , nameAllocAt, nameConFieldsAssign, nameConTagFieldsAssign, nameReuseDrop , nameDropSpecial, nameKeep, nameSetTag - -- * CTail optimization - , nameTpCField, nameTpCTailAcc + -- * TRMC optimization, constructor contexts + , nameTpCCtxx, nameTpCCtx + , nameCCtxCreate + , nameCCtxHoleCreate + , nameCCtxEmpty + , nameCCtxApply + , nameCCtxExtend + , nameCCtxCompose + , nameCCtxComposeExtend + , nameCCtxSetCtxPath + , nameTpFieldAddr, nameFieldAddrOf + + {- + , nameTpCField, + , nameTpCTailAcc , nameCFieldHole - , nameCFieldSet + + -- , nameCFieldSet , nameCFieldOf - , nameCTailNil - , nameCTailLink - , nameCTailResolve + , nameCTailUnit + , nameCTailCompose + , nameCTailApply + , nameCTailSetCtxPath + -} -- * Constructors , nameTrue, nameFalse @@ -267,16 +283,36 @@ nameTpMDict = qualify nameDict (newName "mdict") nameTpDict = qualify nameDict (newName "dict") nameTpBuilder = qualify (newName "std/text/string") (newName "builder") +{- nameTpCTailAcc = cfieldName "ctail" nameTpCField = cfieldName "cfield" nameCFieldHole = cfieldName ".cfield-hole" -nameCFieldSet = cfieldName "cfield-set" -- private (not hidden) nameCFieldOf = cfieldName ".cfield-of" -nameCTailNil = cfieldName ".ctail-nil" -nameCTailLink = cfieldName ".ctail-link" -nameCTailResolve = cfieldName ".ctail-resolve" +nameCTailUnit = cfieldName ".ctail-unit" +nameCTailCompose = cfieldName ".ctail-compose" +nameCTailApply = cfieldName ".ctail-apply" +nameCTailSetCtxPath=cfieldName ".ctail-set-context-path" +-} + cfieldName name = coreTypesName name +nameTpCCtxx = cfieldName "cctx" +nameTpCCtx = cfieldName "ctx" + +nameCCtxCreate = cfieldName ".cctx-create" +nameCCtxHoleCreate= cfieldName ".cctx-hole-create" +nameCCtxExtend = cfieldName ".cctx-extend" +nameCCtxComposeExtend = cfieldName ".cctx-compose-extend" +nameCCtxEmpty = cfieldName "cctx-empty" +nameCCtxSetCtxPath= cfieldName ".cctx-setcp" + +nameCCtxApply = cfieldName "([])" +nameCCtxCompose = cfieldName "(++)" + + +nameTpFieldAddr = cfieldName "field-addr" +nameFieldAddrOf = cfieldName ".field-addr-of" + {-------------------------------------------------------------------------- std/core/hnd --------------------------------------------------------------------------} diff --git a/src/Common/Syntax.hs b/src/Common/Syntax.hs index f7b6acbe0..4c3fae317 100644 --- a/src/Common/Syntax.hs +++ b/src/Common/Syntax.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- Copyright 2012-2021, Microsoft Research, Daan Leijen. +-- Copyright 2012-2023, Microsoft Research, Daan Leijen. -- -- This is free software; you can redistribute it and/or modify it under the -- terms of the Apache License, Version 2.0. A copy of the License can be @@ -13,21 +13,28 @@ module Common.Syntax( Visibility(..) , Assoc(..) , Fixity(..) , DataKind(..) - , DefSort(..), isDefFun, defFun + , DefSort(..), isDefFun, defFun, defFunEx, defSortShowFull , ParamInfo(..) , DefInline(..) + , Fip(..), FipAlloc(..), fipIsTail, fipAlloc, noFip, isNoFip , Target(..), CTarget(..), JsTarget(..), isTargetC, isTargetJS, isTargetWasm , isPublic, isPrivate , DataDef(..) - , dataDefIsRec, dataDefIsOpen, dataDefIsValue + , dataDefIsRec, dataDefIsOpen, dataDefIsValue, dataDefSize + , ValueRepr(..) + , valueReprIsMixed, valueReprIsRaw, valueReprNew, valueReprZero + , valueReprRaw, valueReprSize, valueReprScan, valueReprSizeScan , HandlerSort(..) , isHandlerInstance, isHandlerNormal , OperationSort(..), readOperationSort - , Platform(..), platform32, platform64, platformCS, platformJS + , Platform(..), platform32, platform64, platformCS, platformJS, platform64c + , platformHasCompressedFields , alignedSum, alignedAdd, alignUp , BuildType(..) ) where +import Data.List(intersperse) + {-------------------------------------------------------------------------- Backend targets --------------------------------------------------------------------------} @@ -64,19 +71,29 @@ instance Show Target where C _ -> "c" Default -> "" - -data Platform = Platform{ sizePtr :: Int -- sizeof(intptr_t) - , sizeSize :: Int -- sizeof(size_t) +data Platform = Platform{ sizePtr :: Int -- sizeof(intptr_t) + , sizeSize :: Int -- sizeof(size_t) + , sizeField :: Int -- sizeof(kk_field_t), usually intptr_t but may be smaller for compression + , sizeHeader:: Int -- used for correct alignment calculation } -platform32, platform64 :: Platform -platform32 = Platform 4 4 -platform64 = Platform 8 8 -platformJS = Platform 8 4 -platformCS = Platform 8 4 +platform32, platform64, platform64c, platformJS, platformCS :: Platform +platform32 = Platform 4 4 4 8 +platform64 = Platform 8 8 8 8 +platform64c = Platform 8 8 4 8 -- compressed fields +platformJS = Platform 8 4 8 0 +platformCS = Platform 8 4 8 0 + + +platformHasCompressedFields (Platform sp _ sf _) = (sp /= sf) instance Show Platform where - show (Platform sp ss) = "Platform(sizeof(void*)=" ++ show sp ++ ",sizeof(size_t)=" ++ show ss ++ ")" + show (Platform sp ss sf sh) = "Platform(sizeof(void*)=" ++ show sp ++ + ",sizeof(size_t)=" ++ show ss ++ + ",sizeof(kk_box_t)=" ++ show sf ++ + ",sizeof(kk_header_t)=" ++ show sh ++ + ")" + alignedSum :: Int -> [Int] -> Int alignedSum start xs = foldl alignedAdd start xs @@ -148,6 +165,7 @@ readOperationSort s "fun" -> Just OpFun "brk" -> Just OpExcept "ctl" -> Just OpControl + -- legacy "rawctl" -> Just OpControlRaw "except" -> Just OpExcept "control" -> Just OpControl @@ -165,17 +183,17 @@ instance Show DataKind where show CoInductive = "cotype" show Retractive = "rectype" -data DataDef = DataDefValue{ rawFields :: Int {- size in bytes -}, scanFields :: Int {- count of scannable fields -}} - | DataDefNormal - | DataDefAuto -- Value or Normal; determined by kind inference +data DataDef = DataDefValue !ValueRepr -- value type + | DataDefNormal -- reference type | DataDefRec | DataDefOpen + | DataDefAuto -- Value or Normal; determined by kind inference deriving Eq instance Show DataDef where show dd = case dd of - DataDefValue m n -> "val(raw:" ++ show m ++ ",scan:" ++ show n ++ ")" - DataDefNormal{} -> "normal" + DataDefValue v -> "val" ++ show v + DataDefNormal -> "normal" DataDefRec -> "rec" DataDefOpen -> "open" DataDefAuto -> "auto" @@ -194,15 +212,66 @@ dataDefIsOpen ddef dataDefIsValue ddef = case ddef of - DataDefValue _ _ -> True + DataDefValue{} -> True _ -> False +dataDefSize :: Platform -> DataDef -> Int +dataDefSize platform ddef + = case ddef of + DataDefValue v -> valueReprSize platform v + _ -> sizeField platform + + +{-------------------------------------------------------------------------- + Definition kind +--------------------------------------------------------------------------} + +data ValueRepr = ValueRepr{ valueReprRawSize :: !Int {- size in bytes -}, + valueReprScanCount :: !Int {- count of scannable fields -}, + valueReprAlignment :: !Int {- minimal alignment -} + -- valueReprSize :: !Int {- full size, always rawSize + scanFields*sizeField platform -} + } + deriving (Eq,Ord) + +instance Show ValueRepr where + show (ValueRepr raw scan align) + = "{" ++ concat (intersperse "," (map show [raw,scan,align])) ++ "}" + +valueReprSizeScan :: Platform -> ValueRepr -> (Int,Int) +valueReprSizeScan platform vrepr + = (valueReprSize platform vrepr, valueReprScanCount vrepr) + +valueReprSize :: Platform -> ValueRepr -> Int +valueReprSize platform (ValueRepr raw scan align) = raw + (scan * sizeField platform) + +valueReprIsMixed :: ValueRepr -> Bool +valueReprIsMixed v = (valueReprRawSize v > 0) && (valueReprScanCount v > 0) + +valueReprIsRaw :: ValueRepr -> Bool +valueReprIsRaw v = (valueReprRawSize v > 0) && (valueReprScanCount v == 0) + +valueReprNew :: Int -> Int -> Int -> ValueRepr +valueReprNew rawSize scanCount align + = ValueRepr rawSize scanCount align -- (rawSize + (scanCount * sizeField platform)) + +valueReprZero :: ValueRepr +valueReprZero = ValueRepr 0 0 0 + +valueReprRaw :: Int -> ValueRepr +valueReprRaw m = ValueRepr m 0 m + +valueReprScan :: Int -> ValueRepr +valueReprScan n = ValueRepr 0 n 0 + {-------------------------------------------------------------------------- Definition kind --------------------------------------------------------------------------} data DefSort - = DefFun [ParamInfo] | DefVal | DefVar + = DefFun { defFunParamInfos :: [ParamInfo], + defFunFip :: Fip } + | DefVal + | DefVar deriving Eq data ParamInfo @@ -210,15 +279,26 @@ data ParamInfo | Own deriving(Eq,Show) -isDefFun (DefFun _) = True +isDefFun (DefFun {}) = True isDefFun _ = False +defFunEx :: [ParamInfo] -> Fip -> DefSort +defFunEx pinfos fip = if all (==Own) pinfos then DefFun [] fip else DefFun pinfos fip + defFun :: [ParamInfo] -> DefSort -defFun pinfos = if all (==Own) pinfos then DefFun [] else DefFun pinfos +defFun pinfos = defFunEx pinfos noFip + +defSortShowFull :: DefSort -> String +defSortShowFull ds + = case ds of + DefFun pinfos fip -> show fip ++ "fun" + DefVal -> "val" + DefVar -> "var" + instance Show DefSort where show ds = case ds of - DefFun _ -> "fun" + DefFun{} -> "fun" DefVal -> "val" DefVar -> "var" @@ -248,3 +328,72 @@ data Assoc = AssocNone | AssocRight | AssocLeft deriving (Eq,Show) + + +{-------------------------------------------------------------------------- + Fip +--------------------------------------------------------------------------} +data Fip = Fip { fipAlloc_ :: FipAlloc } + | Fbip { fipAlloc_ :: FipAlloc, fipTail :: Bool } + | NoFip { fipTail :: Bool } + deriving (Eq,Ord) + +data FipAlloc = AllocAtMost Int | AllocFinitely | AllocUnlimited + deriving (Eq) + +instance Ord FipAlloc where + compare a1 a2 + = case (a1, a2) of + (AllocAtMost n, AllocAtMost m) -> compare n m + (_ , AllocAtMost _) -> GT + + (AllocAtMost n, AllocFinitely) -> LT + (AllocFinitely, AllocFinitely) -> EQ + (AllocUnlimited, AllocFinitely) -> GT + + (AllocUnlimited, AllocUnlimited) -> EQ + (_ , AllocUnlimited) -> LT + +instance Semigroup FipAlloc where + AllocAtMost n <> AllocAtMost m = AllocAtMost (n + m) + _ <> _ = AllocFinitely + +instance Monoid FipAlloc where + mempty = AllocAtMost 0 + +noFip :: Fip +noFip = NoFip False + +isNoFip (NoFip _) = True +isNoFip _ = False + +fipIsTail :: Fip -> Bool +fipIsTail fip + = case fip of + Fbip _ t -> t + NoFip t -> t + _ -> True + +fipAlloc :: Fip -> FipAlloc +fipAlloc fip + = case fip of + Fip n -> n + Fbip n _ -> n + NoFip _ -> AllocUnlimited + +instance Show Fip where + show fip = case fip of + Fip n -> "fip" ++ showN n + Fbip n t -> showTail t ++ "fbip" ++ showN n + NoFip t -> showTail t + where + showN (AllocAtMost 0) = " " + showN (AllocAtMost n) = "(" ++ show n ++ ") " + showN AllocFinitely = "(n) " + showN AllocUnlimited = "" + + showTail True = "tail " + showTail _ = " " + + + diff --git a/src/Common/Unique.hs b/src/Common/Unique.hs index cdf8cf366..5335539bd 100644 --- a/src/Common/Unique.hs +++ b/src/Common/Unique.hs @@ -10,7 +10,7 @@ -} ----------------------------------------------------------------------------- module Common.Unique( -- * Unique - HasUnique(updateUnique,setUnique,unique,uniques,uniqueId,uniqueIds,uniqueName) + HasUnique(updateUnique,setUnique,unique,uniques,uniqueId,uniqueIds,uniqueName,uniqueNameFrom) -- ** Instances , Unique, runUnique, runUniqueWith, liftUnique, withUnique , UniqueT, runUniqueT @@ -22,10 +22,6 @@ import Control.Monad import Control.Monad.Trans import Control.Arrow -instance Applicative Unique where - pure = return - (<*>) = ap - class (Monad m, Functor m) => HasUnique m where updateUnique :: (Int -> Int) -> m Int -- getUnique :: m Int @@ -36,6 +32,7 @@ class (Monad m, Functor m) => HasUnique m where uniqueId :: String -> m Id uniqueIds :: String -> Int -> m [Id] uniqueName :: String -> m Name + uniqueNameFrom :: Name -> m Name -- getUnique -- = updateUnique id @@ -61,6 +58,10 @@ class (Monad m, Functor m) => HasUnique m where = do i <- unique return (newHiddenName (baseName ++ "." ++ show i)) + uniqueNameFrom baseName + = do i <- unique + return (toUniqueName i baseName) + {-------------------------------------------------------------------------- Helper instance for unique variables @@ -93,8 +94,12 @@ liftUnique uniq instance Functor Unique where fmap f (Unique u) = Unique (\i -> case u i of (x,j) -> (f x,j)) +instance Applicative Unique where + pure x = Unique (\i -> (x,i)) + (<*>) = ap + instance Monad Unique where - return x = Unique (\i -> (x,i)) + -- return = pure (Unique u) >>= f = Unique (\i -> case u i of (x,j) -> case f x of Unique v -> v j) diff --git a/src/Compiler/Compile.hs b/src/Compiler/Compile.hs index 153e276bb..a449fe740 100644 --- a/src/Compiler/Compile.hs +++ b/src/Compiler/Compile.hs @@ -58,14 +58,16 @@ import Syntax.Colorize ( colorize ) import Core.GenDoc ( genDoc ) import Core.Check ( checkCore ) import Core.UnReturn ( unreturn ) +import Core.CheckFBIP ( checkFBIP ) import Core.OpenResolve ( openResolve ) import Core.FunLift ( liftFunctions ) import Core.Monadic ( monTransform ) import Core.MonadicLift ( monadicLift ) import Core.Inlines ( inlinesExtends, extractInlineDefs, inlinesMerge, inlinesToList, inlinesFilter, inlinesNew ) -import Core.Borrowed ( Borrowed ) +import Core.Borrowed ( Borrowed, borrowedExtendICore ) import Core.Inline ( inlineDefs ) import Core.Specialize +import Core.Unroll ( unrollDefs ) import Static.BindingGroups ( bindingGroups ) import Static.FixityResolve ( fixityResolve, fixitiesNew, fixitiesCompose ) @@ -144,11 +146,11 @@ instance Functor IOErr where fmap f (IOErr ie) = IOErr (fmap (fmap f) ie) instance Applicative IOErr where - pure = return + pure x = IOErr (return (return x)) (<*>) = ap instance Monad IOErr where - return x = IOErr (return (return x)) + -- return = pure (IOErr ie) >>= f = IOErr (do err <- ie case checkError err of Right (x,w) -> case f x of @@ -214,7 +216,7 @@ compileExpression term flags loaded compileTarget program line input [(qnameShow,_)] -> do let expression = mkApp (Var (qualify nameSystemCore (newName "println")) False r) [mkApp (Var qnameShow False r) [mkApp (Var qnameExpr False r) []]] - let defMain = Def (ValueBinder (qualify (getName program) nameMain) () (Lam [] expression r) r r) r Public (DefFun []) InlineNever "" + let defMain = Def (ValueBinder (qualify (getName program) nameMain) () (Lam [] expression r) r r) r Public (defFun []) InlineNever "" let programDef' = programAddDefs programDef [] [defMain] compileProgram' term flags (loadedModules ld) (Executable nameMain ()) "" programDef' return ld @@ -348,15 +350,19 @@ compileProgramFromFile term flags modules compileTarget rootPath stem exist <- liftIO $ doesFileExist fname if (exist) then return () else liftError $ errorMsg (errorFileNotFound flags fname) program <- lift $ parseProgramFromFile (semiInsert flags) fname - let isSuffix = map (\c -> if isPathSep c then '/' else c) (noexts stem) - `endsWith` show (programName program) + let isSuffix = -- asciiEncode True (noexts stem) `endsWith` asciiEncode True (show (programName program)) + -- map (\c -> if isPathSep c then '/' else c) (noexts stem) + show (pathToModuleName (noexts stem)) `endsWith` show (programName program) + -- map (\c -> if isPathSep c then '/' else c) (noexts stem) + -- `endsWith` moduleNameToPath (programName program) ppcolor c doc = color (c (colors (prettyEnvFromFlags flags))) doc if (isExecutable compileTarget || isSuffix) then return () else liftError $ errorMsg (ErrorGeneral (programNameRange program) (text "module name" <+> ppcolor colorModule (pretty (programName program)) <+> text "is not a suffix of the file path" <+> - parens (ppcolor colorSource $ text $ dquote $ stem))) + parens (ppcolor colorSource $ text $ dquote $ stem) + )) let stemName = nameFromFile stem compileProgram' term flags modules compileTarget fname program{ programName = stemName } @@ -449,9 +455,9 @@ compileProgram' term flags modules compileTarget fname program expression = App (Var (if (isHiddenName mainName) then mainName -- .expr else unqualify mainName -- main ) False r) [] r - defMain = Def (ValueBinder (unqualify mainName2) () (Lam [] (f expression) r) r r) r Public (DefFun []) InlineNever "" + defMain = Def (ValueBinder (unqualify mainName2) () (Lam [] (f expression) r) r r) r Public (defFun []) InlineNever "" program2 = programAddDefs program [] [defMain] - in do (loaded3,_) <- typeCheck loaded1 flags 0 coreImports program2 + in do (loaded3,_) <- ignoreWarnings $ typeCheck loaded1 flags 0 coreImports program2 return (Executable mainName2 tp, loaded3) -- TODO: refine the type of main2 [info] -> errorMsg (ErrorGeneral (infoRange info) (text "'main' must be declared as a function (fun)")) @@ -486,9 +492,10 @@ checkUnhandledEffects flags loaded name range tp -> let defaultHandlerName = makeHiddenName "default" effName in -- trace ("looking up: " ++ show defaultHandlerName) $ case gammaLookupQ defaultHandlerName (loadedGamma loaded) of - [InfoFun _ dname _ _ _] + [fun@InfoFun{}] -> trace ("add default effect for " ++ show effName) $ - let g mfx expr = let r = getRange expr + let dname = infoCName fun + g mfx expr = let r = getRange expr in App (Var dname False r) [(Nothing,Lam [] (maybe expr (\f -> f expr) mfx) r)] r in if (effName == nameTpAsync) -- always put async as the most outer effect then do mf' <- combine eff mf ls @@ -864,6 +871,8 @@ inferCheck loaded0 flags line coreImports program -- remove return statements unreturn penv -- checkCoreDefs "unreturn" + let borrowed = borrowedExtendICore (coreProgram{ Core.coreProgDefs = cdefs }) (loadedBorrowed loaded) + checkFBIP penv (platform flags) (loadedNewtypes loaded) borrowed gamma -- initial simplify let ndebug = optimize flags > 0 @@ -874,21 +883,26 @@ inferCheck loaded0 flags line coreImports program simplifyNoDup -- traceDefGroups "simplify1" - -- inline: inline local definitions more aggressively (2x) - when (optInlineMax flags > 0) $ - let inlines = if (isPrimitiveModule (Core.coreProgName coreProgram)) then loadedInlines loaded - else inlinesFilter (\name -> nameId nameCoreHnd /= nameModule name) (loadedInlines loaded) - in inlineDefs penv (2*(optInlineMax flags)) inlines - -- checkCoreDefs "inlined" - - simplifyDupN - -- traceDefGroups "inlined" - -- lift recursive functions to top-level before specialize (so specializeDefs do not contain local recursive definitions) liftFunctions penv checkCoreDefs "lifted" -- traceDefGroups "lifted" + -- unroll recursive definitions (before inline so generated wrappers can be inlined) + when (optUnroll flags > 0) $ + do unrollDefs penv (optUnroll flags) + -- traceDefGroups "unrolled" + + -- inline: inline local definitions more aggressively (2x) + when (optInlineMax flags > 0) $ + do let inlines = if (isPrimitiveModule (Core.coreProgName coreProgram)) then loadedInlines loaded + else inlinesFilter (\name -> nameId nameCoreHnd /= nameModule name) (loadedInlines loaded) + inlineDefs penv (2*(optInlineMax flags)) inlines + -- checkCoreDefs "inlined" + + simplifyDupN + -- traceDefGroups "inlined" + -- specialize specializeDefs <- if (isPrimitiveModule (Core.coreProgName coreProgram)) then return [] else Core.withCoreDefs (\defs -> extractSpecializeDefs (loadedInlines loaded) defs) @@ -905,8 +919,8 @@ inferCheck loaded0 flags line coreImports program -- lifting remaining recursive functions to top level (must be after specialize as that can generate local recursive definitions) liftFunctions penv checkCoreDefs "specialized" - -- traceDefGroups "specialized and lifted" - + -- traceDefGroups "specialized and lifted" + -- simplify once more simplifyDupN coreDefsInlined <- Core.getCoreDefs @@ -918,7 +932,7 @@ inferCheck loaded0 flags line coreImports program -- tail-call-modulo-cons optimization when (optctail flags) $ - ctailOptimize penv (platform flags) newtypes gamma (optctailInline flags) + ctailOptimize penv newtypes gamma (optctailCtxPath flags) -- transform effects to explicit monadic binding (and resolve .open calls) when (enableMon flags && not (isPrimitiveModule (Core.coreProgName coreProgram))) $ @@ -1222,7 +1236,7 @@ codeGenC sourceFile newtypes borrowed0 unique0 term flags modules compileTarget _ -> CDefault (cdoc,hdoc,bcore) = cFromCore ctarget (buildType flags) sourceDir (prettyEnvFromFlags flags) (platform flags) newtypes borrowed0 unique0 (parcReuse flags) (parcSpecialize flags) (parcReuseSpec flags) - (parcBorrowInference flags) (stackSize flags) mbEntry core0 + (parcBorrowInference flags) (optEagerPatBind flags) (stackSize flags) mbEntry core0 bcoreDoc = Core.Pretty.prettyCore (prettyEnvFromFlags flags){ coreIface = False, coreShowDef = True } (C CDefault) [] bcore -- writeDocW 120 (outBase ++ ".c.kkc") bcoreDoc when (showFinalCore flags) $ @@ -1306,7 +1320,7 @@ codeGenC sourceFile newtypes borrowed0 unique0 term flags modules compileTarget case target flags of C Wasm -> do return (Just (mainTarget, - runSystemEcho term flags (wasmrun flags ++ " " ++ dquote mainTarget ++ cmdflags ++ " " ++ execOpts flags))) + runSystemEcho term flags (wasmrun flags ++ " " ++ dquote mainTarget ++ " -- " ++ cmdflags ++ " " ++ execOpts flags))) C WasmWeb -> do return (Just (mainTarget, runSystemEcho term flags (dquote mainTarget ++ " &"))) C WasmJs @@ -1345,30 +1359,20 @@ copyCLibrary term flags cc eimport = case Core.eimportLookup (buildType flags) "library" eimport of Nothing -> return [] Just clib - -> do mb <- do -- use conan? - mbConan <- case lookup "conan" eimport of - Just pkg | not (null (conan flags)) - -> conanCLibrary term flags cc eimport clib pkg - _ -> return (Left []) - case mbConan of + -> do mb <- do mbSearch <- search [] [ searchCLibrary flags cc clib (ccompLibDirs flags) + , case lookup "conan" eimport of + Just pkg | not (null (conan flags)) + -> conanCLibrary term flags cc eimport clib pkg + _ -> return (Left []) + , case lookup "vcpkg" eimport of + Just pkg + -> vcpkgCLibrary term flags cc eimport clib pkg + _ -> return (Left []) + ] + case mbSearch of Right res -> return (Just res) - Left conanWarns - -> do -- use vcpkg? (we prefer this as conan is not working well on windows across cl, clang, and mingw) - mbVcpkg <- case lookup "vcpkg" eimport of - Just pkg - -> vcpkgCLibrary term flags cc eimport clib pkg - _ -> return (Left []) - case mbVcpkg of - Right res -> return (Just res) - Left vcpkgWarns - -> do -- try to find the library and headers directly - mbSearch <- searchCLibrary flags cc clib (ccompLibDirs flags) - case mbSearch of - Right res -> return (Just res) - Left searchWarns - -> do let warns = intersperse (text "or") (vcpkgWarns ++ conanWarns ++ searchWarns) - termWarning term flags (vcat warns) - return Nothing + Left warn -> do termWarning term flags warn + return Nothing case mb of Just (libPath,includes) -> do termPhaseDoc term (color (colorInterpreter (colorScheme flags)) (text "library:") <+> @@ -1383,7 +1387,14 @@ copyCLibrary term flags cc eimport text " hint: provide \"--cclibdir\" as an option, or use \"syslib\" in an extern import?" raiseIO ("unable to find C library " ++ clib ++ "\nlibrary search paths: " ++ show (ccompLibDirs flags)) - + where + search :: [Doc] -> [IO (Either [Doc] (FilePath,[FilePath]))] -> IO (Either Doc (FilePath,[FilePath])) + search warns [] = return (Left (vcat (intersperse (text "or") warns))) + search warns (io:ios) + = do mbRes <- io + case mbRes of + Right res -> return (Right res) + Left warns' -> search (warns ++ warns') ios searchCLibrary :: Flags -> CC -> FilePath -> [FilePath] -> IO (Either [Doc] (FilePath {-libPath-},[FilePath] {-include paths-})) searchCLibrary flags cc clib searchPaths diff --git a/src/Compiler/Module.hs b/src/Compiler/Module.hs index 3af52bf5c..1c1bd29f9 100644 --- a/src/Compiler/Module.hs +++ b/src/Compiler/Module.hs @@ -38,7 +38,7 @@ import Kind.Newtypes ( Newtypes, newtypesEmpty, newtypesCompose, extrac import Kind.Constructors ( Constructors, constructorsEmpty, constructorsCompose, extractConstructors ) import Kind.Assumption ( KGamma, kgammaInit, extractKGamma, kgammaUnion ) -import Type.Assumption ( Gamma, gammaInit, gammaUnion, extractGamma, gammaNames) +import Type.Assumption ( Gamma, gammaInit, gammaUnion, extractGamma, gammaNames, gammaPublicNames) import Type.Type ( DataInfo ) import Core.Inlines ( Inlines, inlinesNew, inlinesEmpty, inlinesExtends ) import Core.Borrowed ( Borrowed, borrowedEmpty, borrowedExtendICore ) @@ -125,7 +125,7 @@ loadedNames l loadedMatchNames :: Loaded -> [String] loadedMatchNames l - = map (showPlain . unqualify) $ filter (not . isHiddenName) (loadedNames l) + = map (showPlain . unqualify) $ gammaPublicNames (loadedGamma l) where -- good (c:_) = (c /= '.') diff --git a/src/Compiler/Options.hs b/src/Compiler/Options.hs index b90ed590d..94b3c0093 100644 --- a/src/Compiler/Options.hs +++ b/src/Compiler/Options.hs @@ -175,7 +175,9 @@ data Flags , optimize :: Int -- optimization level; 0 or less is off , optInlineMax :: Int , optctail :: Bool - , optctailInline :: Bool + , optctailCtxPath :: Bool + , optUnroll :: Int + , optEagerPatBind :: Bool -- bind pattern fields as early as possible? , parcReuse :: Bool , parcSpecialize :: Bool , parcReuseSpec :: Bool @@ -183,6 +185,7 @@ data Flags , asan :: Bool , useStdAlloc :: Bool -- don't use mimalloc for better asan and valgrind support , optSpecialize :: Bool + , mimallocStats :: Bool } flagsNull :: Flags @@ -268,7 +271,9 @@ flagsNull 0 -- optimize 12 -- inlineMax True -- optctail - False -- optctailInline + True -- optctailCtxPath + (-1) -- optUnroll + False -- optEagerPatBind (read fields as late as possible) True -- parc reuse True -- parc specialize True -- parc reuse specialize @@ -276,6 +281,7 @@ flagsNull False -- use asan False -- use stdalloc True -- use specialization (only used if optimization level >= 1) + False -- use mimalloc stats isHelp Help = True isHelp _ = False @@ -367,18 +373,21 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip -- hidden , hide $ fflag ["asan"] (\b f -> f{asan=b}) "compile with address, undefined, and leak sanitizer" , hide $ fflag ["stdalloc"] (\b f -> f{useStdAlloc=b}) "use the standard libc allocator" + , hide $ fflag ["allocstats"] (\b f -> f{mimallocStats=b}) "enable mimalloc statitistics" , hide $ fnum 3 "n" ["simplify"] (\i f -> f{simplify=i}) "enable 'n' core simplification passes" , hide $ fnum 10 "n" ["maxdup"] (\i f -> f{simplifyMaxDup=i}) "set 'n' as maximum code duplication threshold" , hide $ fnum 10 "n" ["inline"] (\i f -> f{optInlineMax=i}) "set 'n' as maximum inline threshold (=10)" , hide $ fflag ["monadic"] (\b f -> f{enableMon=b}) "enable monadic translation" , hide $ flag [] ["semi"] (\b f -> f{semiInsert=b}) "insert semicolons based on layout" - , hide $ fflag ["binference"] (\b f -> f{parcBorrowInference=b}) "enable reuse inference (does not work cross-module!)" - , hide $ fflag ["optreuse"] (\b f -> f{parcReuse=b}) "enable in-place update analysis" - , hide $ fflag ["optdropspec"] (\b f -> f{parcSpecialize=b}) "enable drop specialization" - , hide $ fflag ["optreusespec"] (\b f -> f{parcReuseSpec=b}) "enable reuse specialization" - , hide $ fflag ["opttrmc"] (\b f -> f{optctail=b}) "enable tail-recursion-modulo-cons optimization" - , hide $ fflag ["opttrmcinline"] (\b f -> f{optctailInline=b}) "enable trmc inlining (increases code size)" - , hide $ fflag ["specialize"] (\b f -> f{optSpecialize=b}) "enable inline specialization" + , hide $ fflag ["binference"] (\b f -> f{parcBorrowInference=b}) "enable reuse inference (does not work cross-module!)" + , hide $ fflag ["reuse"] (\b f -> f{parcReuse=b}) "enable in-place update analysis" + , hide $ fflag ["dropspec"] (\b f -> f{parcSpecialize=b}) "enable drop specialization" + , hide $ fflag ["reusespec"] (\b f -> f{parcReuseSpec=b}) "enable reuse specialization" + , hide $ fflag ["trmc"] (\b f -> f{optctail=b}) "enable tail-recursion-modulo-cons optimization" + , hide $ fflag ["trmcctx"] (\b f -> f{optctailCtxPath=b}) "enable trmc context paths" + , hide $ fflag ["specialize"] (\b f -> f{optSpecialize=b}) "enable inline specialization" + , hide $ fflag ["unroll"] (\b f -> f{optUnroll=(if b then 1 else 0)}) "enable recursive definition unrolling" + , hide $ fflag ["eagerpatbind"] (\b f -> f{optEagerPatBind=b}) "load pattern fields as early as possible" -- deprecated , hide $ option [] ["cmake"] (ReqArg cmakeFlag "cmd") "use to invoke cmake" @@ -437,6 +446,7 @@ options = (\(xss,yss) -> (concat xss, concat yss)) $ unzip [("c", \f -> f{ target=C LibC, platform=platform64 }), ("c64", \f -> f{ target=C LibC, platform=platform64 }), ("c32", \f -> f{ target=C LibC, platform=platform32 }), + ("c64c", \f -> f{ target=C LibC, platform=platform64c }), ("js", \f -> f{ target=JS JsNode, platform=platformJS }), ("jsnode", \f -> f{ target=JS JsNode, platform=platformJS }), ("jsweb", \f -> f{ target=JS JsWeb, platform=platformJS }), @@ -657,8 +667,11 @@ processOptions flags0 opts ccCheckExist cc let stdAlloc = if asan then True else useStdAlloc flags -- asan implies useStdAlloc cdefs = ccompDefs flags - ++ if stdAlloc then [] else [("KK_MIMALLOC",show (sizePtr (platform flags)))] - ++ if (buildType flags > DebugFull) then [] else [("KK_DEBUG_FULL","")] + ++ (if stdAlloc then [] else [("KK_MIMALLOC",show (sizePtr (platform flags)))]) + ++ (if (buildType flags > DebugFull) then [] else [("KK_DEBUG_FULL","")]) + ++ (if optctailCtxPath flags then [] else [("KK_CTAIL_NO_CONTEXT_PATH","")]) + ++ (if platformHasCompressedFields (platform flags) then [("KK_INTB_SIZE",show (sizeField (platform flags)))] else []) + ++ (if not stdAlloc && mimallocStats flags then [("MI_STAT","2")] else []) -- vcpkg -- (vcpkgRoot,vcpkg) <- vcpkgFindRoot (vcpkgRoot flags) @@ -696,7 +709,10 @@ processOptions flags0 opts else if (optimize flags <= 1) then (optInlineMax flags) `div` 3 else (optInlineMax flags), - + optctailCtxPath = (optctailCtxPath flags && isTargetC (target flags)), + optUnroll = if (optUnroll flags < 0) + then (if (optimize flags > 0) then 1 else 0) + else optUnroll flags, ccompPath = ccmd, ccomp = cc, ccompDefs = cdefs, @@ -950,9 +966,11 @@ buildVariant flags Wasm -> "-wasm" ++ show (8*sizePtr (platform flags)) WasmJs -> "-wasmjs" WasmWeb-> "-wasmweb" - _ -> "") - JS _ -> "js" - _ -> show (target flags) + _ | platformHasCompressedFields (platform flags) + -> "-" ++ cpuArch ++ "c" + | otherwise -> "") + JS _ -> "-js" + _ -> "-" ++ show (target flags) in pre ++ "-" ++ show (buildType flags) @@ -1094,6 +1112,8 @@ ccFromPath flags path ,True) else if (useStdAlloc flags) then return (cc{ ccName = ccName cc ++ "-stdalloc" }, False) + else if (mimallocStats flags) + then return (cc{ ccName = ccName cc ++ "-allocstats" }, False) else return (cc,False) ccCheckExist :: CC -> IO () diff --git a/src/Core/AnalysisCCtx.hs b/src/Core/AnalysisCCtx.hs new file mode 100644 index 000000000..a3eeb9121 --- /dev/null +++ b/src/Core/AnalysisCCtx.hs @@ -0,0 +1,330 @@ +----------------------------------------------------------------------------- +-- Copyright 2012-2023, Microsoft Research, Daan Leijen. +-- +-- This is free software; you can redistribute it and/or modify it under the +-- terms of the Apache License, Version 2.0. A copy of the License can be +-- found in the LICENSE file at the root of this distribution. +----------------------------------------------------------------------------- + +{- + Check if a constructor context is well formed, and create a context path +-} + +module Core.AnalysisCCtx( analyzeCCtx, + + makeCCtxEmpty, + makeCCtxCreate, + makeCCtxSetContextPath, + makeFieldAddrOf + -- getFieldName + ) where + + +import Control.Monad +import Lib.Trace +import Lib.PPrint +import Common.Syntax( Target(..), JsTarget(..), CTarget(..) ) +import Common.Id +import Common.Name +import Common.NamePrim(nameCCtxHoleCreate,nameCCtxCreate,nameCCtxEmpty,nameCCtxSetCtxPath, + nameFieldAddrOf,nameTpFieldAddr, + nameEffectOpen) +import Common.Range +import Common.Unique(HasUnique(..)) +import Common.Failure +import Common.Syntax +import Kind.Newtypes +import Kind.Kind +import Type.Type +import Type.Pretty as Pretty +import Type.TypeVar +import Core.Core +import Core.Pretty + +-- take a context and check if it is well-formed and return a well-typed context expression +analyzeCCtx :: Range -> Newtypes -> Expr -> (Int -> ((Expr,[(Range,Doc)]),Int)) +analyzeCCtx rng newtypes expr uniq + = let (res,uniq') = runCCtx rng newtypes uniq (cctxCreate expr) + in case res of + Right e -> ((e,[]),uniq') + Left errs -> let errs' = if null errs then [(rng,text "ill-formed context")] + else errs + in ((makeCCtxEmpty (typeOf expr),errs'),uniq) + + +data Hole = Hole{ holeAddr :: Expr, holeType :: Type } +data Ctx = Ctx{ defs :: [Def], top :: Expr, hole :: Hole } + +cctxCreate :: Expr -> CCtx Expr +-- empty context? +cctxCreate expr | isHole expr + = do return (makeCCtxEmpty (typeOf expr)) +-- non-empty context +cctxCreate expr + = do -- mtrace ("expr: " ++ show expr) + (Ctx defs top (Hole addr holetp)) <- cctxExpr expr + let tp = typeOf top + let cctx = makeCCtxCreate tp holetp top addr + return (Let (map DefNonRec defs) cctx) + + +cctxExpr :: Expr -> CCtx Ctx +cctxExpr expr + = case expr of + -- constructor + App con@(Con name repr) args | conReprHasCtxPath repr && not (null args) + -> cctxCon name repr [] args + + App (TypeApp (con@(Con name repr)) targs) args | conReprHasCtxPath repr && not (null args) + -> cctxCon name repr targs args + + -- App (App (TypeApp (Var open _) [effFrom,effTo,tpFrom,tpTo]) [f]) []) | getName open == nameEffectOpen + + _ -> illegal + + {- + Var _ _ -> illegal "var" + Lam _ _ _ -> illegal "lambda" + TypeLam _ e -> illegal "" + Lit _ -> illegal + Let dgs e -> + Case _ _ -> + App _ _ -> + -} + +-- todo: check dataRepr for non-value constructor +cctxCon :: TName -> ConRepr -> [Type] -> [Expr] -> CCtx Ctx +cctxCon conName conRepr targs args + = case span (not . isHole) args of + (pre,hole:post) + -> cctxConFinal conName conRepr targs pre hole post + _ -> cctxConRecurse conName conRepr targs args + +cctxConRecurse :: TName -> ConRepr -> [Type] -> [Expr] -> CCtx Ctx +cctxConRecurse conName conRepr targs args + = do -- mtrace "recurse" + (pre,ctx,post) <- cctxFind [] [] args + mapM_ cctxCheckNoHole (pre ++ post) + (ds,vars) <- unzip <$> mapM makeUniqueDef pre + fname <- getFieldName conName (length pre + 1) + let ctxrepr = conRepr{ conCtxPath = CtxField fname } + (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName ctxrepr) targs) (vars ++ [top ctx] ++ post)) + -- (d2,var2) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) + return (ctx{ defs = ds ++ defs ctx ++ [d1], top = var1 }) + +cctxConFinal :: TName -> ConRepr -> [Type] -> [Expr] -> Expr -> [Expr] -> CCtx Ctx +cctxConFinal conName conRepr targs pre hole post + = do -- mtrace "final" + mapM_ cctxCheckNoHole (pre ++ post) + fname <- getFieldName conName (length pre + 1) + let holetp = typeOf hole + ctxrepr = conRepr{ conCtxPath = CtxField fname } + ensureValidHoleType holetp + (d1,var1) <- makeUniqueDef (App (makeTypeApp (Con conName ctxrepr) targs) (pre ++ [hole] ++ post)) + (d2,addr) <- makeUniqueDef (makeFieldAddrOf var1 conName (getName fname) holetp) + -- (d3,var3) <- makeUniqueDef (makeCCtxSetContextPath var1 conName fname) -- should be last as it consumes var1 + return (Ctx [d1,d2] var1 (Hole addr holetp)) + +cctxCheckNoHole :: Expr -> CCtx () +cctxCheckNoHole expr + = -- note: not needed as it as already checked during type inference + return () + + +cctxFind :: [(Range,Doc)] -> [Expr] -> [Expr] -> CCtx ([Expr],Ctx,[Expr]) +-- no args +cctxFind errs acc [] + = emitErrors errs +-- try recursively +cctxFind errs acc (arg:args) + = do r <- try (cctxExpr arg) + case r of + Left errs' -> cctxFind (errs ++ errs') (arg:acc) args + Right ctx -> return (reverse acc,ctx,args) + + +illegal + = emitErrors [] + +makeUniqueDef :: Expr -> CCtx (Def,Expr) +makeUniqueDef expr + = do name <- uniqueName "cctx" + return (makeDef name expr, Var (TName name (typeOf expr)) InfoNone) + +isHole :: Expr -> Bool +isHole (App (TypeApp (Var (TName hname htp) _) [tp,_etp]) []) = (hname == nameCCtxHoleCreate) +isHole (App (App (TypeApp (Var open _) [effFrom,effTo,tpFrom,tpTo]) [TypeApp (Var hname _) _]) []) + = (getName open == nameEffectOpen) && (getName hname == nameCCtxHoleCreate) +isHole _ = False + +-- Initial empty context (ctx hole) +makeCCtxEmpty :: Type -> Expr +makeCCtxEmpty tp + = App (TypeApp (Var (TName nameCCtxEmpty funType) + -- (InfoArity 1 0) + (InfoExternal [(C CDefault,"kk_cctx_empty(kk_context())"),(JS JsDefault,"$std_core_types._cctx_empty()")]) + ) [tp]) [] + where + funType = TForall [a] [] (TFun [] typeTotal (typeCCtx (TVar a))) + a = TypeVar 0 kindStar Bound + + +-- Create a context (ctx Cons(e,Cons(2,hole))) +makeCCtxCreate :: Type -> Type -> Expr -> Expr -> Expr +makeCCtxCreate tp holetp top holeaddr + = App (TypeApp (Var (TName nameCCtxCreate funType) + -- (InfoArity 1 3) + (InfoExternal [(C CDefault,"kk_cctx_create(#1,#2,kk_context())"), + (JS JsDefault,"$std_core_types._cctx_create(#1,#2)")]) + ) [tp,holetp]) [top,holeaddr] + where + funType = TForall [a,b] [] (TFun [(nameNil,TVar a), + (nameNil,TApp typeFieldAddr [TVar a])] + typeTotal (TApp typeCCtxx [TVar a,TVar b])) + a = TypeVar 0 kindStar Bound + b = TypeVar 1 kindStar Bound + + +-- The adress of a field in a constructor (for context holes) +makeFieldAddrOf :: Expr -> TName -> Name -> Type -> Expr +makeFieldAddrOf obj conName fieldName fieldTp + = App (TypeApp (Var (TName nameFieldAddrOf funType) (InfoExternal [])) [fieldTp]) + [obj, Lit (LitString (showTupled (getName conName))), Lit (LitString (showTupled fieldName))] + where + funType = TForall [a] [] (TFun [(nameNil,TVar a),(nameNil,typeString),(nameNil,typeString)] + typeTotal (TApp typeFieldAddr [TVar a])) + a = TypeVar 0 kindStar Bound + +-- Set the index of the field in a constructor to follow the path to the hole at runtime. +makeCCtxSetContextPath :: Expr -> TName -> Name -> Expr +makeCCtxSetContextPath obj conName fieldName + = App (Var (TName nameCCtxSetCtxPath funType) (InfoExternal [(Default,".cctx-setcp(#1,#2,#3)")])) + [obj, Lit (LitString (showTupled (getName conName))), Lit (LitString (showTupled fieldName))] + where + tp = typeOf obj + funType = (TFun [(nameNil,tp),(nameNil,typeString),(nameNil,typeString)] typeTotal tp) + + +{-------------------------------------------------------------------------- + CC Monad +--------------------------------------------------------------------------} + +newtype CCtx a = CCtx (Int -> CCtxEnv -> Result a) + +runCCtx :: Range -> Newtypes -> Int -> CCtx a -> (Either [(Range,Doc)] a,Int) +runCCtx rng nt uniq (CCtx c) + = case (c uniq (CCtxEnv rng nt)) of + Ok x u' -> (Right x,u') + Err errs -> (Left errs,uniq) + + + +data CCtxEnv = CCtxEnv{ rng :: Range, newtypes :: Newtypes } + +data Result a = Err [(Range,Doc)] + | Ok a Int + +instance Functor CCtx where + fmap f (CCtx c) = CCtx (\u env -> case c u env of + Ok x u' -> Ok (f x) u' + Err errs -> Err errs) + +instance Applicative CCtx where + pure x = CCtx (\u g -> Ok x u) + (<*>) = ap + +instance Monad CCtx where + -- return = pure + (CCtx c) >>= f = CCtx (\u g -> case c u g of + Ok x u' -> case f x of + CCtx d -> d u' g + Err errs -> Err errs) + +instance HasUnique CCtx where + updateUnique f = CCtx (\u g -> Ok u (f u)) + setUnique i = CCtx (\u g -> Ok () i) + +getEnv :: CCtx CCtxEnv +getEnv + = CCtx (\u g -> Ok g u) + +withEnv :: CCtxEnv -> CCtx a -> CCtx a +withEnv env (CCtx c) + = CCtx (\u _ -> c u env) + +updateEnv :: (CCtxEnv -> CCtxEnv) -> CCtx a -> CCtx a +updateEnv f (CCtx c) + = CCtx (\u env -> c u (f env)) + +emitError :: Doc -> CCtx a +emitError doc + = do env <- getEnv + emitErrors [(rng env,doc)] + +emitErrors :: [(Range,Doc)] -> CCtx a +emitErrors errs + = do -- mtrace ("emit errors: " ++ show errs) + (CCtx (\u env -> Err errs)) + + +try :: CCtx a -> CCtx (Either [(Range,Doc)] a) +try (CCtx c) + = CCtx (\u env -> case c u env of + Ok x u' -> Ok (Right x) u' + Err errs -> Ok (Left errs) u) + + +mtrace :: String -> CCtx () +mtrace msg + = do env <- getEnv + trace ("Core.AnalysisCCtx: " ++ msg) $ + return () + +getFieldName :: TName -> Int -> CCtx TName +getFieldName cname fieldIdx + = do info <- lookupFieldName cname fieldIdx + case info of + Left err -> failure ("Core.AnalysisCCtx: " ++ err) + Right name -> return name + +ensureValidHoleType :: Type -> CCtx () +ensureValidHoleType tp + = do env <- getEnv + case dataTypeNameOf tp of + Left (TVar{}) -> emitError (text "the hole in the constructor context has an unresolved or polymorphic type") + Left _ -> emitError (text "the hole in the constructor context has an invalid data type") + Right name -> case newtypesLookupAny name (newtypes env) of + Just dataInfo -> + do let (dataRepr,_) = getDataRepr dataInfo + when (dataDefIsValue (dataInfoDef dataInfo) || dataReprIsValue dataRepr) $ + emitError (text "the hole in a constructor context cannot be a value type") + return () + +dataTypeNameOf :: Type -> Either Type Name +dataTypeNameOf tp = case expandSyn tp of + TApp t ts -> dataTypeNameOf t + TCon tc -> Right (typeConName tc) + t -> Left t + + +lookupFieldName :: TName -> Int -> CCtx (Either String TName) +lookupFieldName cname field + = do env <- getEnv + case newtypesLookupAny (getDataTypeName cname) (newtypes env) of + Just dataInfo -> + do let (dataRepr,_) = getDataRepr dataInfo + if (dataReprIsValue dataRepr) + then return (Left ("contexts cannot go through a value type (" ++ show (getName cname) ++ ")")) + else do case filter (\con -> conInfoName con == getName cname) (dataInfoConstrs dataInfo) of + [con] -> case drop (field - 1) (conInfoParams con) of + ((fname,ftp):_) -> return $ Right (TName fname ftp) {- Con cname (getConRepr dataInfo con), fname) -} + _ -> failure $ "Core.CTail.getFieldName: field index is off: " ++ show cname ++ ", field " ++ show field ++ ", in " ++ show (conInfoParams con) + _ -> failure $ "Core.CTail.getFieldName: cannot find constructor: " ++ show cname ++ ", field " ++ show field ++ ", in " ++ show (dataInfoConstrs dataInfo) + _ -> failure $ "Core.CTail.getFieldName: no such constructor: " ++ show cname ++ ", field " ++ show field + where + getDataTypeName cname = case splitFunScheme (typeOf cname) of + Just (_,_,_,_,tres) -> getDataTypeNameRes tres + Nothing -> failure $ "Core.CTail.getFieldName: illegal constructor type: " ++ show cname ++ ", field " ++ show field ++ ": " ++ show (pretty (typeOf cname)) + getDataTypeNameRes tp = case dataTypeNameOf tp of + Right name -> name + _ -> failure $ "Core.CTail.getFieldName: illegal result type: " ++ show cname ++ ", field " ++ show field ++ ": " ++ show (pretty (typeOf cname)) diff --git a/src/Core/Borrowed.hs b/src/Core/Borrowed.hs index 87a8a11c6..e44ba97e5 100644 --- a/src/Core/Borrowed.hs +++ b/src/Core/Borrowed.hs @@ -89,7 +89,7 @@ extractBorrowExternals exs extractExternal :: External -> Maybe BorrowDef extractExternal ex = case ex of - External name _ params _ _ _ _ -> + External name _ params _ _ _ _ _ -> if Borrow `elem` params then Just (name, params) else Nothing _ -> Nothing @@ -101,7 +101,7 @@ extractDefGroup (DefNonRec def) extractBorrowDef :: Bool -> Def -> Maybe BorrowDef extractBorrowDef isRec def = case defSort def of - DefFun pinfos | not (null pinfos) -> Just (defName def,pinfos) + DefFun pinfos _ | not (null pinfos) -> Just (defName def,pinfos) _ -> Nothing instance Show Borrowed where diff --git a/src/Core/CTail.hs b/src/Core/CTail.hs index 30ad55f2b..2f5afdc8c 100644 --- a/src/Core/CTail.hs +++ b/src/Core/CTail.hs @@ -8,7 +8,9 @@ {-# LANGUAGE NamedFieldPuns, GeneralizedNewtypeDeriving #-} ----------------------------------------------------------------------------- --- Tail Recursive Modulo Cons implementation (called "ctail") +-- Tail Recursive Modulo Cons implementation +-- See: "Tail Recursion Modulo Context -- An Equational Approach", +-- Daan Leijen and Anton Lorenzen, POPL'22. ----------------------------------------------------------------------------- module Core.CTail ( ctailOptimize, uctailOptimize ) where @@ -17,7 +19,6 @@ import Lib.Trace (trace) import Control.Monad import Control.Monad.Reader import Control.Monad.State -import Data.Char import Data.Maybe (catMaybes) import qualified Data.Set as S import qualified Data.IntMap as M @@ -25,9 +26,9 @@ import qualified Data.IntMap as M import Kind.Kind import Kind.Newtypes import Type.Type -import Type.Kind (effectIsAffine ) +import Type.Kind (effectIsAffine) import qualified Type.Pretty as Pretty -import Type.Assumption hiding (InfoExternal)-- Gamma +import Type.Assumption (Gamma) import Lib.PPrint import Common.NamePrim @@ -42,14 +43,14 @@ import Core.Pretty -------------------------------------------------------------------------- -- Reference count transformation -------------------------------------------------------------------------- -ctailOptimize :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> CorePhase () -ctailOptimize penv platform newtypes gamma ctailInline +ctailOptimize :: Pretty.Env -> Newtypes -> Gamma -> Bool -> CorePhase () +ctailOptimize penv newtypes gamma useContextPath = liftCorePhaseUniq $ \uniq defs -> - runUnique uniq (uctailOptimize penv platform newtypes gamma ctailInline defs) + runUnique uniq (uctailOptimize penv newtypes gamma useContextPath defs) -uctailOptimize :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> DefGroups -> Unique DefGroups -uctailOptimize penv platform newtypes gamma ctailInline defs - = ctailRun penv platform newtypes gamma ctailInline (ctailDefGroups True defs) +uctailOptimize :: Pretty.Env -> Newtypes -> Gamma -> Bool -> DefGroups -> Unique DefGroups +uctailOptimize penv newtypes gamma useContextPath defs + = ctailRun penv newtypes gamma useContextPath (ctailDefGroups True defs) -------------------------------------------------------------------------- -- Definition groups @@ -69,11 +70,18 @@ ctailDefGroup topLevel dg _ -> return [dg] where log - | DefRec [def] <- dg = "ctailDefGroup: " ++ show (defName def) ++ " " ++ (if (hasCTailCall (defTName def) True (defExpr def)) then "IS " else "is NOT ") ++ "eligible for ctail" - | DefRec defs <- dg = "ctailDefGroup: found larger DefRec with names: " ++ unwords [show (defName def) | def <- defs ] + | DefRec [def] <- dg = "ctailDefGroup: " ++ show (defName def) ++ " " ++ (if (hasCTailCall (defTName def) True (defExpr def)) then "IS " else "is NOT ") ++ "eligible for ctail" + | DefRec defs <- dg = "ctailDefGroup: found larger DefRec with names: " ++ unwords [show (defName def) | def <- defs ] | DefNonRec def <- dg = "ctailDefGroup: found DefNonRec with name: " ++ show (defName def) +{- +we generate +- if the runtime can copy contexts (setContextPath) + we always generate a single definition which is optimized a bit if the effect is affine for sure (alwaysAffine) +- otherwise, a single definition of the effect is affine for sure (alwaysAffine) +- or two definitions for multiple resumptions (isMulti) +-} ctailDef :: Bool -> Def -> CTail [DefGroup] ctailDef topLevel def = withCurrentDef def $ @@ -83,27 +91,29 @@ ctailDef topLevel def Nothing -> return [DefRec [def]] Just (tforall,tpreds,targs,teff,tres) -> do -- ctailTrace "- has reference type result" - let ctailSlotType = TApp typeCTail [tres] - ctailName = makeHiddenName "ctail" (defName def) + let ctailSlotType = typeCCtx tres + ctailName = makeHiddenName "trmc" (defName def) ctailSlot = newHiddenName "acc" ctailType = tForall tforall tpreds (TFun (targs ++ [(ctailSlot,ctailSlotType)]) teff tres) ctailTName= TName ctailName ctailType ctailTSlot= TName ctailSlot ctailSlotType - cdefExpr <- withContext ctailTName False (Just ctailTSlot) $ + let alwaysAffine = effectIsAffine teff + cdefExpr <- withContext ctailTName False {-isMulti-} alwaysAffine (Just ctailTSlot) $ ctailExpr True (makeCDefExpr ctailTSlot (defExpr def)) + useContextPath <- getUseContextPath let cdef = def{ defName = ctailName, defType = ctailType, defExpr = cdefExpr } - needsMulti = not (effectIsAffine teff) + needsMulti = not (useContextPath || alwaysAffine) ctailMultiSlotType = TFun [(nameNil,tres)] typeTotal tres - ctailMultiName = makeHiddenName "ctailm" (defName def) + ctailMultiName = makeHiddenName "trmcm" (defName def) ctailMultiSlot = newHiddenName "accm" ctailMultiType = tForall tforall tpreds (TFun (targs ++ [(ctailMultiSlot,ctailMultiSlotType)]) teff tres) ctailMultiTName = TName ctailMultiName ctailMultiType ctailMultiTSlot = TName ctailMultiSlot ctailMultiSlotType ctailMultiVar = Var ctailMultiTName (InfoArity (length tforall) (length targs + 1)) - wrapExpr <- withContext ctailTName False Nothing $ + wrapExpr <- withContext ctailTName False alwaysAffine Nothing $ do ctailWrapper ctailTSlot (if needsMulti then Just ctailMultiVar else Nothing) (defExpr def) @@ -113,7 +123,7 @@ ctailDef topLevel def then -- for sure, each op resumes at most once return [ DefRec [cdef, def{defExpr = wrapExpr }] ] else -- some ops may resume more than once; specialize for those - do cdefMultiExpr <- withContext ctailMultiTName True (Just ctailMultiTSlot) $ + do cdefMultiExpr <- withContext ctailMultiTName True {-isMulti-} alwaysAffine (Just ctailMultiTSlot) $ ctailExpr True (makeCDefExpr ctailMultiTSlot (defExpr def)) let cdefMulti = def{ defName = ctailMultiName, defType = ctailMultiType, defExpr = cdefMultiExpr } return $ [ DefRec [cdef, cdefMulti, def{defExpr = wrapExpr} ] ] @@ -158,7 +168,7 @@ ctailWrapperBody :: Type -> TName -> Maybe Expr -> [TypeVar] -> [TName] -> CTail ctailWrapperBody resTp slot mbMulti targs args = do tailVar <- getCTailFun let ctailCall = App (makeTypeApp tailVar [TVar tv | tv <- targs]) - ([Var name InfoNone | name <- args] ++ [makeCTailNil resTp]) + ([Var name InfoNone | name <- args] ++ [makeCCtxEmpty resTp]) case mbMulti of Nothing -> return ctailCall Just ctailMultiVar @@ -237,7 +247,7 @@ ctailExpr top expr case (expr',mbSlot) of (App v@(Var ctailmSlot _) [arg], Just slot) | getName ctailmSlot == getName slot -> return (App v [TypeApp arg targs]) -- push down typeapp - (App v@(TypeApp (Var ctailResolve _) _) [acc,arg],_) | getName ctailResolve == nameCTailResolve + (App v@(TypeApp (Var ctailApply _) _) [acc,arg],_) | getName ctailApply == nameCCtxApply -> return (App v [acc,TypeApp arg targs]) -- push down typeapp into ctail set _ -> return (TypeApp expr' targs) @@ -261,13 +271,18 @@ ctailExpr top expr case mbSlot of Nothing -> return body Just slot -> do isMulti <- getIsMulti - return (makeCTailResolve isMulti slot body) - - handleConApp dname cname f fargs - = do let mkCons args = bindArgs args $ (\xs -> return ([],App f xs)) - mbExpr <- ctailTryArg dname cname Nothing mkCons (length fargs) (reverse fargs) + alwaysAffine <- getIsAlwaysAffine + return (makeCCtxApply isMulti alwaysAffine slot body) + + handleConApp dname cname fcon fargs + = do let mkCons cpath args = bindArgs args $ \xs -> return ([],mkConApp cpath fcon xs) + isMulti <- getIsMulti + useContextPath <- getUseContextPath + alwaysAffine <- getIsAlwaysAffine + let useCtx = not isMulti && useContextPath && not alwaysAffine + mbExpr <- ctailTryArg useCtx dname cname Nothing mkCons (length fargs) (reverse fargs) case mbExpr of - Nothing -> tailResult (App f fargs) + Nothing -> tailResult (App fcon fargs) Just (defs,expr) -> return (makeLet defs expr) handleTailCall mkCall @@ -277,6 +292,16 @@ ctailExpr top expr Just slot -> do ctailVar <- getCTailFun -- do a tail call with the current slot return (mkCall ctailVar (Var slot InfoNone)) +mkConApp :: CtxPath -> Expr -> [Expr] -> Expr +mkConApp cpath fcon xs + = case cpath of + CtxField fname -> case fcon of + Con conName conRepr -> App (Con conName conRepr{conCtxPath=cpath}) xs + TypeApp (Con conName conRepr) targs -> App (TypeApp (Con conName conRepr{conCtxPath=cpath}) targs) xs + _ -> failure ("Core.CTail.mkConApp: invalid constructor: " ++ show fcon) + _ -> App fcon xs + + bindArgs :: [Expr] -> ([Expr] -> CTail ([DefGroup],Expr)) -> CTail ([DefGroup],Expr) bindArgs args use = do (defss,args') <- unzip <$> mapM bindArg args @@ -305,9 +330,9 @@ ctailGuard (Guard test expr) -- expects patAdded in depth-order -- See if the tailcall is inside a (nested) constructor application -------------------------------------------------------------------------- -ctailTryArg :: TName -> TName -> Maybe TName -> ([Expr] -> CTail ([DefGroup],Expr)) -> Int -> [Expr] -> CTail (Maybe ([DefGroup],Expr)) -ctailTryArg dname cname mbC mkApp field [] = return Nothing -ctailTryArg dname cname mbC mkApp field (rarg:rargs) +ctailTryArg :: Bool -> TName -> TName -> Maybe TName -> (CtxPath -> [Expr] -> CTail ([DefGroup],Expr)) -> Int -> [Expr] -> CTail (Maybe ([DefGroup],Expr)) +ctailTryArg useCtxPath dname cname mbC mkApp field [] = return Nothing +ctailTryArg useCtxPath dname cname mbC mkApp field (rarg:rargs) = case rarg of App f@(TypeApp (Var name info) targs) fargs | (dname == name) -> do expr <- ctailFoundArg cname mbC mkAppNew field @@ -321,20 +346,57 @@ ctailTryArg dname cname mbC mkApp field (rarg:rargs) -- recurse into other con App f@(TypeApp (Con cname2 _) _) fargs | tnamesMember dname (fv fargs) -- && all isTotal rargs -> do x <- uniqueTName (typeOf rarg) - ctailTryArg dname cname2 (Just x) (mkAppNested x f) (length fargs) (reverse fargs) + ctailTryArg useCtxPath dname cname2 (Just x) (mkAppNested x f) (length fargs) (reverse fargs) App f@(Con cname2 _) fargs | tnamesMember dname (fv fargs) -- && all isTotal rargs -> do x <- uniqueTName (typeOf rarg) - ctailTryArg dname cname2 (Just x) (mkAppNested x f) (length fargs) (reverse fargs) + ctailTryArg useCtxPath dname cname2 (Just x) (mkAppNested x f) (length fargs) (reverse fargs) - _ -> if (isTotal rarg) then ctailTryArg dname cname mbC (\args -> mkApp (args ++ [rarg])) (field-1) rargs + _ -> if (isTotal rarg) then ctailTryArg useCtxPath dname cname mbC (\cpath args -> mkApp cpath (args ++ [rarg])) (field-1) rargs else return Nothing where - mkAppNew = (\args -> mkApp (reverse rargs ++ args)) - mkAppNested x f - = (\args -> do (defs,expr) <- bindArgs (reverse rargs) $ \xs -> mkApp (xs ++ [Var x InfoNone]) - return ([DefNonRec (makeTDef x (App f args))]++defs, expr)) - + -- create a tail call + mkAppNew + = \args -> do cpath <- getCtxPath useCtxPath cname field + mkApp cpath (reverse rargs ++ args) + {- + if not useCtxPath then return (defs,cexpr) + else do setfld <- setContextPathExpr cname field + x <- uniqueTName (typeOf cexpr) + y <- uniqueTName (typeOf cexpr) + let cexprdef = DefNonRec (makeTDef y cexpr) + let setdef = DefNonRec (makeTDef x (setfld y)) + return (defs ++ [cexprdef,setdef], (Var x InfoNone)) -} + + + -- create the constructor context (ending in a hole) + mkAppNested :: TName -> Expr -> (CtxPath -> [Expr] -> CTail ([DefGroup],Expr)) + mkAppNested x fcon + = \fcpath args -> do cpath <- getCtxPath useCtxPath cname field + (defs,expr) <- bindArgs (reverse rargs) $ \xs -> mkApp cpath (xs ++ [Var x InfoNone]) + let condef = DefNonRec (makeTDef x (mkConApp fcpath fcon args)) + return ([condef] ++ defs, expr) + {- + --(defs,expr) <- bindArgs (reverse rargs) $ \xs -> mkApp cpath (xs ++ [Var x InfoNone]) + if not useCtxPath + then do let condef = DefNonRec (makeTDef x (App fcon args)) + return ([condef] ++ defs, expr) + else do setfld <- setContextPathExpr cname field + y <- uniqueTName (typeOf x) + let condef = DefNonRec (makeTDef y (App fcon args)) + let setdef = DefNonRec (makeTDef x (setfld y)) + return ([condef,setdef] ++ defs, expr) + -} + +getCtxPath :: Bool -> TName -> Int -> CTail CtxPath +getCtxPath False cname fieldIdx = return CtxNone +getCtxPath useContextPath cname fieldIdx + = do fieldInfo <- getFieldName cname fieldIdx + case fieldInfo of + Left msg -> failure msg -- todo: allow this? see test/cgen/ctail7 + Right (_,fieldName) -> return (CtxField fieldName) + + -------------------------------------------------------------------------- -- Found a tail call inside a constructor application @@ -362,11 +424,12 @@ ctailFoundArg cname mbC mkConsApp field mkTailApp resTp -- f fargs Left msg -> failure msg -- todo: allow this? see test/cgen/ctail7 Right (_,fieldName) -> do let -- tp = typeOf (App f fargs) - hole = makeCFieldHole resTp + hole = makeHole resTp (defs,cons) <- mkConsApp [hole] consName <- uniqueTName (typeOf cons) - let link = makeCTailLink slot consName (maybe consName id mbC) cname fieldName resTp - ctailCall = mkTailApp ctailVar link -- App ctailVar (fargs ++ [link]) + alwaysAffine <- getIsAlwaysAffine + let comp = makeCCtxExtend slot consName (maybe consName id mbC) cname (getName fieldName) resTp alwaysAffine + ctailCall = mkTailApp ctailVar comp return $ (defs ++ [DefNonRec (makeTDef consName cons)] ,ctailCall) @@ -375,73 +438,85 @@ ctailFoundArg cname mbC mkConsApp field mkTailApp resTp -- f fargs -- Primitives -------------------------------------------------------------------------- -makeCFieldHole :: Type -> Expr -makeCFieldHole tp - = App (TypeApp (Var (TName nameCFieldHole funType) (InfoExternal [])) [tp]) [] +-- Polymorphic hole +makeHole :: Type -> Expr +makeHole tp + = App (TypeApp (Var (TName nameCCtxHoleCreate funType) (InfoExternal [])) [tp]) [] where funType = TForall [a] [] (TFun [] typeTotal (TVar a)) a = TypeVar 0 kindStar Bound -makeCTailNil :: Type -> Expr -makeCTailNil tp - = App (TypeApp (Var (TName nameCTailNil funType) +-- Initial empty context (@ctx hole) +makeCCtxEmpty :: Type -> Expr +makeCCtxEmpty tp + = App (TypeApp (Var (TName nameCCtxEmpty funType) -- (InfoArity 1 0) - (InfoExternal [(C CDefault,"kk_ctail_nil()"),(JS JsDefault,"$std_core_types._ctail_nil()")]) + (InfoExternal [(C CDefault,"kk_cctx_empty(kk_context())"),(JS JsDefault,"$std_core_types._cctx_empty()")]) ) [tp]) [] where - funType = TForall [a] [] (TFun [] typeTotal (TApp typeCTail [TVar a])) + funType = TForall [a] [] (TFun [] typeTotal (typeCCtx (TVar a))) a = TypeVar 0 kindStar Bound -makeCFieldOf :: TName -> TName -> Name -> Type -> Expr -makeCFieldOf objName conName fieldName tp - = App (TypeApp (Var (TName nameCFieldOf funType) (InfoExternal [])) [tp]) +-- The adress of a field in a constructor (for context holes) +makeFieldAddrOf :: TName -> TName -> Name -> Type -> Expr +makeFieldAddrOf objName conName fieldName tp + = App (TypeApp (Var (TName nameFieldAddrOf funType) (InfoExternal [])) [tp]) [Var objName InfoNone, Lit (LitString (showTupled (getName conName))), Lit (LitString (showTupled fieldName))] where funType = TForall [a] [] (TFun [(nameNil,TVar a),(nameNil,typeString),(nameNil,typeString)] - typeTotal (TApp typeCField [TVar a])) + typeTotal (TApp typeFieldAddr [TVar a])) a = TypeVar 0 kindStar Bound -makeCTailLink :: TName -> TName -> TName -> TName -> Name -> Type -> Expr -makeCTailLink slot resName objName conName fieldName tp - = let fieldOf = makeCFieldOf objName conName fieldName tp - in App (TypeApp (Var (TName nameCTailLink funType) +-- Extend a context with a non-empty context +makeCCtxExtend :: TName -> TName -> TName -> TName -> Name -> Type -> Bool -> Expr +makeCCtxExtend slot resName objName conName fieldName tp alwaysAffine + = let fieldOf = makeFieldAddrOf objName conName fieldName tp + in App (TypeApp (Var (TName nameCCtxExtend funType) -- (InfoArity 1 3) - (InfoExternal [(C CDefault,"kk_ctail_link(#1,#2,#3)"),(JS JsDefault,"$std_core_types._ctail_link(#1,#2,#3)")]) + (InfoExternal [(C CDefault,"kk_cctx_extend(#1,#2,#3," ++ affine ++ ",kk_context())"), + (JS JsDefault,"$std_core_types._cctx_extend(#1,#2,#3)")]) ) [tp]) [Var slot InfoNone, Var resName InfoNone, fieldOf] where - funType = TForall [a] [] (TFun [(nameNil,TApp typeCTail [TVar a]), + affine = if alwaysAffine then "true" else "false" + funType = TForall [a] [] (TFun [(nameNil,typeCCtx (TVar a)), (nameNil,TVar a), - (nameNil,TApp typeCField [TVar a])] typeTotal (TApp typeCTail [TVar a])) + (nameNil,TApp typeFieldAddr [TVar a])] typeTotal (typeCCtx (TVar a))) a = TypeVar 0 kindStar Bound -makeCTailResolve :: Bool -> TName -> Expr -> Expr -makeCTailResolve True slot expr -- slot `a -> a` is an accumulating function; apply to resolve + +-- Apply a context to its final value. +makeCCtxApply :: Bool {-isMulti-} -> Bool {-isAlwaysAffine-} -> TName -> Expr -> Expr +makeCCtxApply True _ slot expr -- slot `a -> a` is an accumulating function; apply to resolve = App (Var slot InfoNone) [expr] -makeCTailResolve False slot expr -- slot is a `ctail` - = App (TypeApp (Var (TName nameCTailResolve funType) +makeCCtxApply False alwaysAffine slot expr -- slot is a `ctail` + = App (TypeApp (Var (TName nameCCtxApply funType) -- (InfoArity 1 2) - (InfoExternal [(Default,"kk_ctail_resolve(#1,#2)"),(JS JsDefault,"$std_core_types._ctail_resolve(#1,#2)")]) + (InfoExternal [(C CDefault,"kk_cctx_apply(#1,#2," ++ affine ++ ",kk_context())"), + (JS JsDefault,"$std_core_types._cctx_apply(#1,#2)")]) ) [tp]) [Var slot InfoNone, expr] where + affine = if alwaysAffine then "true" else "false" tp = case typeOf slot of TApp _ [t] -> t - funType = TForall [a] [] (TFun [(nameNil,TApp typeCTail [TVar a]),(nameNil,TVar a)] typeTotal (TVar a)) + TSyn _ [t] _ -> t + funType = TForall [a] [] (TFun [(nameNil,typeCCtx (TVar a)),(nameNil,TVar a)] typeTotal (TVar a)) a = TypeVar (-1) kindStar Bound + -------------------------------------------------------------------------- -- Utilities for readability -------------------------------------------------------------------------- -- create a unique name specific to this module uniqueTName :: Type -> CTail TName -uniqueTName tp = (`TName` tp) <$> uniqueName "ctail" +uniqueTName tp = (`TName` tp) <$> uniqueName "trmc" -- for mapping over a set and collecting the results into a list. foldMapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b] @@ -463,13 +538,13 @@ maybeStats xs expr data Env = Env { currentDef :: [Def], prettyEnv :: Pretty.Env, - platform :: Platform, newtypes :: Newtypes, gamma :: Gamma, - ctailInline :: Bool, ctailName :: TName, ctailSlot :: Maybe TName, - isMulti :: Bool + isMulti :: Bool, + useContextPath :: Bool, + alwaysAffine :: Bool } data CTailState = CTailState { uniq :: Int } @@ -495,18 +570,18 @@ updateSt = modify getSt :: CTail CTailState getSt = get -ctailRun :: Pretty.Env -> Platform -> Newtypes -> Gamma -> Bool -> CTail a -> Unique a -ctailRun penv platform newtypes gamma ctailInline (CTail action) +ctailRun :: Pretty.Env -> Newtypes -> Gamma -> Bool -> CTail a -> Unique a +ctailRun penv newtypes gamma useContextPath (CTail action) = withUnique $ \u -> - let env = Env [] penv platform newtypes gamma ctailInline (TName nameNil typeUnit) Nothing True + let env = Env [] penv newtypes gamma (TName nameNil typeUnit) Nothing True useContextPath False st = CTailState u (val, st') = runState (runReaderT action env) st in (val, uniq st') -withContext :: TName -> Bool -> Maybe TName -> CTail a -> CTail a -withContext name isMulti mbSlot action - = withEnv (\env -> env{ ctailName = name, ctailSlot = mbSlot, isMulti = isMulti }) action +withContext :: TName -> Bool -> Bool -> Maybe TName -> CTail a -> CTail a +withContext name isMulti alwaysAffine mbSlot action + = withEnv (\env -> env{ ctailName = name, ctailSlot = mbSlot, isMulti = isMulti, alwaysAffine = alwaysAffine }) action getCTailFun :: CTail Expr getCTailFun @@ -524,17 +599,25 @@ getIsMulti :: CTail Bool getIsMulti = isMulti <$> getEnv -getFieldName :: TName -> Int -> CTail (Either String (Expr,Name)) +getUseContextPath :: CTail Bool +getUseContextPath + = useContextPath <$> getEnv + +getIsAlwaysAffine :: CTail Bool +getIsAlwaysAffine + = alwaysAffine <$> getEnv + +getFieldName :: TName -> Int -> CTail (Either String (Expr,TName)) getFieldName cname field = do env <- getEnv case newtypesLookupAny (getDataTypeName cname) (newtypes env) of Just dataInfo -> do let (dataRepr,_) = getDataRepr dataInfo if (dataReprIsValue dataRepr) - then return (Left ("cannot optimize modulo-cons tail-call over a value type (" ++ show (getName cname) ++ ")")) + then return (Left ("cannot optimize modulo-cons tail-call through a value type (" ++ show (getName cname) ++ ")")) else do case filter (\con -> conInfoName con == getName cname) (dataInfoConstrs dataInfo) of [con] -> case drop (field - 1) (conInfoParams con) of - ((fname,ftp):_) -> return $ Right (Con cname (getConRepr dataInfo con), fname) + ((fname,ftp):_) -> return $ Right (Con cname (getConRepr dataInfo con), TName fname ftp) _ -> failure $ "Core.CTail.getFieldName: field index is off: " ++ show cname ++ ", field " ++ show field ++ ", in " ++ show (conInfoParams con) _ -> failure $ "Core.CTail.getFieldName: cannot find constructor: " ++ show cname ++ ", field " ++ show field ++ ", in " ++ show (dataInfoConstrs dataInfo) _ -> failure $ "Core.CTail.getFieldName: no such constructor: " ++ show cname ++ ", field " ++ show field @@ -570,11 +653,6 @@ getPrettyEnv = prettyEnv <$> getEnv withPrettyEnv :: (Pretty.Env -> Pretty.Env) -> CTail a -> CTail a withPrettyEnv f = withEnv (\e -> e { prettyEnv = f (prettyEnv e) }) -getPlatform :: CTail Platform -getPlatform = platform <$> getEnv - -getOptCtailInline :: CTail Bool -getOptCtailInline = ctailInline <$> getEnv --------------------- -- state accessors -- diff --git a/src/Core/Check.hs b/src/Core/Check.hs index 83e6db736..4a7413295 100644 --- a/src/Core/Check.hs +++ b/src/Core/Check.hs @@ -70,11 +70,11 @@ instance Functor Check where Err doc -> Err doc) instance Applicative Check where - pure = return - (<*>) = ap + pure x = Check (\u g -> Ok x u) + (<*>) = ap instance Monad Check where - return x = Check (\u g -> Ok x u) + -- return = pure (Check c) >>= f = Check (\u g -> case c u g of Ok x u' -> case f x of Check d -> d u' g diff --git a/src/Core/CheckFBIP.hs b/src/Core/CheckFBIP.hs new file mode 100644 index 000000000..586a979f3 --- /dev/null +++ b/src/Core/CheckFBIP.hs @@ -0,0 +1,737 @@ +----------------------------------------------------------------------------- +-- Copyright 2020-2022, Microsoft Research, Daan Leijen, Anton Lorenzen +-- +-- This is free software; you can redistribute it and/or modify it under the +-- terms of the Apache License, Version 2.0. A copy of the License can be +-- found in the LICENSE file at the root of this distribution. +----------------------------------------------------------------------------- + +----------------------------------------------------------------------------- +-- Check if a function is FIP/FBIP +----------------------------------------------------------------------------- + +module Core.CheckFBIP( checkFBIP + ) where + + +import qualified Lib.Trace +import Control.Monad +import Data.List (foldl', tails, uncons, isSuffixOf, foldl1', partition, sortOn) +import qualified Data.Set as S +import qualified Data.Map as M + +import Lib.PPrint +import Common.Name +import Common.Range +import Common.Unique +import Common.Error +import Common.Syntax + +import Kind.Newtypes + +import Type.Type +import Type.Pretty hiding (Env) +import qualified Type.Pretty as Pretty +import Type.Assumption +import Core.Core +import qualified Core.Core as Core +import Core.Pretty +import Core.CoreVar +import Core.Borrowed +import Common.NamePrim (nameEffectEmpty, nameTpDiv, nameEffectOpen, namePatternMatchError, nameTpException, nameTpPartial, nameTrue, + nameCCtxSetCtxPath, nameFieldAddrOf, nameTpInt) +import Backend.C.ParcReuse (getFixedDataAllocSize) +import Backend.C.Parc (getDataInfo') +import Data.Ratio +import Data.Ord (Down (Down)) +import Control.Monad.Reader +import Control.Monad.Writer +import Common.Id + +trace s x = + Lib.Trace.trace s + x + + +checkFBIP :: Pretty.Env -> Platform -> Newtypes -> Borrowed -> Gamma -> CorePhase () +checkFBIP penv platform newtypes borrowed gamma + = do uniq <- unique + defGroups <- getCoreDefs + let (_,warns) = runChk penv uniq platform newtypes borrowed gamma (chkDefGroups defGroups) + mapM_ (\warn -> liftError (warningMsg warn)) warns + + +{-------------------------------------------------------------------------- + check definition groups +--------------------------------------------------------------------------} + +chkDefGroups :: DefGroups -> Chk () +chkDefGroups = mapM_ chkDefGroup + +chkDefGroup :: DefGroup -> Chk () +chkDefGroup defGroup + = case defGroup of + DefRec defs -> mapM_ (chkTopLevelDef (map defName defs)) defs + DefNonRec def -> chkTopLevelDef [defName def] def + +chkTopLevelDef :: [Name] -> Def -> Chk () +chkTopLevelDef defGroupNames def + = withCurrentDef def $ do + case defSort def of + -- only check fip and fbip annotated functions + DefFun borrows fip | not (isNoFip fip) -> + withFip fip $ + do out <- extractOutput $ + withInput (\_ -> Input S.empty defGroupNames True) $ + chkTopLevelExpr borrows (defExpr def) + checkOutputEmpty out + _ -> return () + +-- | Lambdas at the top-level are part of the signature and not allocations. +chkTopLevelExpr :: [ParamInfo] -> Expr -> Chk () +chkTopLevelExpr borrows (Lam pars eff body) + = do chkEffect eff + let bpars = map snd $ filter ((==Borrow) . fst) $ zipParamInfo borrows pars + let opars = map snd $ filter ((==Own) . fst) $ zipParamInfo borrows pars + withBorrowed (S.fromList $ map getName bpars) $ do + out <- extractOutput $ chkExpr body + writeOutput =<< foldM (\out nm -> bindName nm Nothing out) out opars +chkTopLevelExpr borrows (TypeLam _ body) + = chkTopLevelExpr borrows body +chkTopLevelExpr borrows (TypeApp body _) + = chkTopLevelExpr borrows body +chkTopLevelExpr borrows expr + = chkExpr expr + +chkExpr :: Expr -> Chk () +chkExpr expr + = case expr of + TypeLam _ body -> chkExpr body + TypeApp body _ -> chkExpr body + Lam pars eff body + -> do chkEffect eff + requireCapability mayAlloc $ \ppenv -> Just $ + text "allocating a lambda expression" + out <- extractOutput $ chkExpr body + writeOutput =<< foldM (\out nm -> bindName nm Nothing out) out pars + + App (TypeApp (Var tname _) _) _ | getName tname `elem` [nameCCtxSetCtxPath] -> return () + + App fn args -> chkApp fn args + Var tname info -> markSeen tname info + + Let [] body -> chkExpr body + Let (DefNonRec def:dgs) body + -> do out <- extractOutput $ chkExpr (Let dgs body) + gamma2 <- bindName (defTName def) Nothing out + writeOutput gamma2 + withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ + withTailMod [Let dgs body] $ chkExpr $ defExpr def + Let _ _ + -> emitWarning $ \penv -> text "internal: currently the fip analysis cannot handle nested function bindings" + + Case scrutinees branches + -> chkBranches scrutinees branches + Con _ _ -> pure () -- Atoms are non-allocated + Lit lit -> chkLit lit + +chkModCons :: [Expr] -> Chk () +chkModCons [] = pure () +chkModCons args + = zipWithM_ (\a tl -> withTailMod tl $ chkExpr a) args (tail $ tails args) + +chkBranches :: [Expr] -> [Branch] -> Chk () +chkBranches scrutinees branches + = do whichBorrowed <- mapM isBorrowedScrutinee scrutinees + let branches' = filter (not . isPatternMatchError) branches + outs <- mapM (extractOutput . chkBranch whichBorrowed) branches' + gamma2 <- joinContexts (map branchPatterns branches') outs + writeOutput gamma2 + withBorrowed (S.map getName $ M.keysSet $ gammaNm gamma2) $ + withTailModProduct branches' $ -- also filter out pattern match errors + mapM_ chkScrutinee $ zip whichBorrowed scrutinees + +isBorrowedScrutinee :: Expr -> Chk ParamInfo +isBorrowedScrutinee expr@(Var tname info) + = do b <- isBorrowed tname + pure $ if b then Borrow else Own +isBorrowedScrutinee _ = pure Own + +chkScrutinee :: (ParamInfo, Expr) -> Chk () +chkScrutinee (Borrow, Var tname info) = pure () +chkScrutinee (_, expr) = chkExpr expr + +chkBranch :: [ParamInfo] -> Branch -> Chk () +chkBranch whichBorrowed (Branch pats guards) + = do let (borPats, ownPats) = partition ((==Borrow) .fst) $ zip whichBorrowed pats + outs <- withBorrowed (S.map getName $ bv $ map snd borPats) $ + mapM (extractOutput . chkGuard) guards + out <- joinContexts (repeat pats) outs + writeOutput =<< foldM (flip bindPattern) out (map snd ownPats) + +chkGuard :: Guard -> Chk () +chkGuard (Guard test expr) + = do out <- extractOutput $ chkExpr expr + withBorrowed (S.map getName $ M.keysSet $ gammaNm out) $ + withNonTail $ chkExpr test + writeOutput out + +-- | We ignore default branches that create a pattern match error +isPatternMatchError :: Branch -> Bool +isPatternMatchError (Branch pats [Guard (Con gname _) (App (TypeApp (Var (TName fnname _) _) _) _)]) + | all isPatWild pats && getName gname == nameTrue && fnname == namePatternMatchError = True + where isPatWild PatWild = True; isPatWild _ = False +isPatternMatchError _ = False + +bindPattern :: Pattern -> Output -> Chk Output +bindPattern (PatCon cname pats crepr _ _ _ _ _) out + = do size <- getConstructorAllocSize crepr + provideToken cname size =<< foldM (flip bindPattern) out pats +bindPattern (PatVar tname (PatCon cname pats crepr _ _ _ _ _)) out + = do size <- getConstructorAllocSize crepr + bindName tname (Just size) =<< foldM (flip bindPattern) out pats +bindPattern (PatVar tname PatWild) out + = bindName tname Nothing out +bindPattern (PatVar tname pat) out -- Else, don't bind the name. + = bindPattern pat out -- The end of the analysis fails if the name is actually used. +bindPattern (PatLit _) out = pure out +bindPattern PatWild out = pure out + + + +chkApp :: Expr -> [Expr] -> Chk () +chkApp (TypeLam _ fn) args = chkApp fn args -- ignore type machinery +chkApp (TypeApp fn _) args = chkApp fn args +chkApp (App (TypeApp (Var openName _) _) [fn]) args | getName openName == nameEffectOpen + = chkApp fn args +chkApp (Con cname repr) args -- try reuse + = do chkModCons args + chkAllocation cname repr +chkApp (Var tname info) args | not (infoIsRefCounted info) -- toplevel function + = do bs <- getParamInfos (getName tname) + withNonTail $ mapM_ chkArg $ zipParamInfo bs args + chkFunCallable (getName tname) + input <- getInput + unless (isTailContext input || getName tname `notElem` defGroupNames input) $ + requireCapability mayRecurse $ \ppenv -> Just $ + cat [text "non-tail call to a (mutually) recursive function: ", ppName ppenv (getName tname)] +chkApp fn args -- local function + = do withNonTail $ mapM_ chkExpr args + isBapp <- case fn of -- does the bapp rule apply? + Var tname _ -> isBorrowed tname + _ -> pure False + unless isBapp $ do + requireCapability mayDealloc $ \ppenv -> Just $ + vcat [text "owned calls to functions require deallocation: ", source ppenv (prettyExpr ppenv fn) ] + chkExpr fn + +chkArg :: (ParamInfo, Expr) -> Chk () +chkArg (Own, expr) = chkExpr expr +chkArg (Borrow, expr) + = case expr of + (TypeLam _ fn) -> chkArg (Borrow, fn) + (TypeApp fn _) -> chkArg (Borrow, fn) + (App (TypeApp (Var openName _) _) [fn]) | getName openName == nameEffectOpen + -> chkArg (Borrow, fn) -- disregard .open calls + (Var tname info) -> markBorrowed tname info + (Lit _) -> pure () + _ -> do chkExpr expr + requireCapability mayDealloc $ \ppenv -> Just $ + vcat [text "passing owned expressions as borrowed causes deallocation:", source ppenv (prettyExpr ppenv expr)] + +chkLit :: Lit -> Chk () +chkLit lit + = case lit of + LitInt _ -> pure () -- we do not care about allocating big integers + LitFloat _ -> pure () + LitChar _ -> pure () + LitString _ -> pure () + -- requireCapability mayAlloc $ \ppenv -> Just $ + -- text "Inline string literals are allocated. Consider lifting to toplevel to avoid this." + +chkWrap :: TName -> VarInfo -> Chk () +chkWrap tname info + = do bs <- getParamInfos (getName tname) + unless (Borrow `notElem` bs) $ + emitWarning $ \penv -> text "a function with borrowed parameters is passed as an argument and implicitly wrapped (causing allocation)" + +chkAllocation :: TName -> ConRepr -> Chk () +chkAllocation cname repr | isConAsJust repr = pure () +chkAllocation cname repr | "_noreuse" `isSuffixOf` nameId (conTypeName repr) + = requireCapability mayAlloc $ \ppenv -> Just $ + cat [text "types suffixed with _noreuse are not reused: ", ppName ppenv $ conTypeName repr] +chkAllocation cname crepr + = do size <- getConstructorAllocSize crepr + -- chkTrace $ "Allocation " ++ show cname ++ "/" ++ show size + getAllocation cname size + +-- Only total/empty effects or divergence +chkEffect :: Tau -> Chk () +chkEffect tp + = if isFBIPExtend tp then pure () else + emitWarning $ \penv -> text "algebraic effects other than" <+> ppType penv typePure <+> text "may cause allocation." + where + isFBIPExtend tp = case extractEffectExtend tp of + (taus, tau) -> all isFBIP taus + isFBIP tp = case expandSyn tp of + TCon tc -> typeConName tc `elem` [nameEffectEmpty,nameTpDiv,nameTpPartial] + TApp tc1 [TCon (TypeCon nm _)] -> tc1 == tconHandled && nm == nameTpPartial + _ -> False + +{-------------------------------------------------------------------------- + Chk monad +--------------------------------------------------------------------------} +type Chk a = ReaderT (Env, Input) (WriterT (Output, [(Range,Doc)]) Unique) a + +data Env = Env{ currentDef :: [Def], + prettyEnv :: Pretty.Env, + platform :: Platform, + newtypes :: Newtypes, + borrowed :: Borrowed, + gamma :: Gamma, + fip :: Fip + } + +data Input = Input{ delta :: S.Set Name, + defGroupNames :: [Name], + isTailContext :: Bool } + +data AllocTree + = Alloc Id -- ^ allocation with unique identifier + | Call FipAlloc -- ^ call using allocation credits + | CallSelf FipAlloc -- ^ self-call using allocation credits + | Seq AllocTree AllocTree + | Match [AllocTree] + | Leaf + +data Output = Output{ gammaNm :: M.Map TName Int, + -- ^ matches variables to their number of uses + gammaDia :: M.Map Int [(Ratio Int, [(TName,Id)])], + -- ^ matches token size to allocations with a "probability" + -- sorted in descending order of probability + allocTree :: AllocTree } + +instance Semigroup Output where + Output s1 m1 t1 <> Output s2 m2 t2 = + Output (M.unionWith (+) s1 s2) (M.unionWith (\x y -> sortOn (Down . fst) (x ++ y)) m1 m2) (Seq t1 t2) + +instance Monoid Output where + mempty = Output M.empty M.empty Leaf + +prettyGammaNm :: Pretty.Env -> Output -> Doc +prettyGammaNm ppenv (Output nm dia _) + = tupled $ map + (\(nm, cnt) -> cat [ppName ppenv (getName nm), text "/", pretty cnt]) + (M.toList nm) + +prettyCon :: Pretty.Env -> TName -> Int -> Doc +prettyCon ppenv tname sz + = ppName ppenv (getName tname) <.> text "/" <.> pretty (sz {-`div` 8-}) + +prettyGammaDia :: Pretty.Env -> Output -> Doc +prettyGammaDia ppenv (Output nm dia _) + = tupled $ concatMap + (\(sz, cs) -> map (\(_, (c,_):_) -> prettyCon ppenv c sz) cs) + (M.toList dia) + +runChk :: Pretty.Env -> Int -> Platform -> Newtypes -> Borrowed -> Gamma -> Chk a -> (a,[(Range,Doc)]) +runChk penv u platform newtypes borrowed gamma c + = fst $ runUnique 0 $ + fmap (fmap snd) $ runWriterT $ + runReaderT c (Env [] penv platform newtypes borrowed gamma noFip, Input S.empty [] True) + +withEnv :: (Env -> Env) -> Chk a -> Chk a +withEnv f = withReaderT (\(e, i) -> (f e, i)) + +getEnv :: Chk Env +getEnv = asks fst + +withInput :: (Input -> Input) -> Chk a -> Chk a +withInput f = withReaderT (\(e, i) -> (e, f i)) + +getInput :: Chk Input +getInput = asks snd + +writeOutput :: Output -> Chk () +writeOutput out = tell (out, []) + +withFip :: Fip -> Chk a -> Chk a +withFip f chk + = withEnv (\env -> env{fip=f}) chk + +getFip :: Chk Fip +getFip = fip <$> getEnv + +mayRecurse :: Chk Bool +mayRecurse + = do fip <- getFip + pure $ case fip of + Fip n -> False + Fbip n isTail -> not isTail + NoFip isTail -> not isTail + +mayDealloc :: Chk Bool +mayDealloc + = do fip <- getFip + pure $ case fip of + Fip n -> False + _ -> True + +mayAlloc :: Chk Bool +mayAlloc = (==AllocUnlimited) . fipAlloc <$> getFip + +isCallableFrom :: Fip -> Fip -> Bool +isCallableFrom a b + = case (a, b) of + (Fip _, _) -> True + (Fbip _ _, Fbip _ _) -> True + (_, NoFip _) -> True + _ -> False + +writeCallAllocation :: Name -> Fip -> Chk () +writeCallAllocation fn fip + = do defs <- currentDefNames + let call = if fn `elem` defs then CallSelf else Call + case fip of + Fip n -> tell (Output mempty mempty (call n), mempty) + Fbip n _ -> tell (Output mempty mempty (call n), mempty) + NoFip _ -> pure () + +getFipInfo :: [NameInfo] -> Maybe Fip +getFipInfo xs + = case xs of + [info] -> case info of + InfoFun _ _ _ _ fip' _ + -> Just fip' + Type.Assumption.InfoExternal _ _ _ _ fip' _ + -> Just fip' + _ -> Nothing + infos -> Nothing + +chkFunCallable :: Name -> Chk () +chkFunCallable fn + = do fip <- getFip + g <- gamma <$> getEnv + case getFipInfo (gammaLookupCanonical fn g) of + Nothing | fn `elem` [nameCCtxSetCtxPath,nameFieldAddrOf] + -> writeCallAllocation fn (Fip (AllocAtMost 0)) + Nothing + -> emitWarning $ \penv -> text "internal: fip analysis could not find fip information for function:" <+> ppName penv fn + Just fip' + -> if fip' `isCallableFrom` fip then writeCallAllocation fn fip' + else emitWarning $ \penv -> text "calling a non-fip function:" <+> ppName penv fn + +-- | Run the given check, keep the warnings but extract the output. +extractOutput :: Chk () -> Chk Output +extractOutput f + = do ((), (out, doc)) <- censor (const mempty) $ listen f + tell (mempty, doc) + pure out + +-- | Perform a test if the capability is not present +-- and emit a warning if the test is unsuccessful. +requireCapability :: Chk Bool -> (Pretty.Env -> Maybe Doc) -> Chk () +requireCapability mayUseCap test + = do hasCap <- mayUseCap + unless hasCap $ do + env <- getEnv + case test (prettyEnv env) of + Just warning -> emitWarning (\_ -> warning) + Nothing -> pure () + +withNonTail :: Chk a -> Chk a +withNonTail + = withInput (\st -> st { isTailContext = False }) + +-- | Tail modulo a pattern-match. This handles modulo product contexts. +withTailModProduct :: [Branch] -> Chk a -> Chk a +withTailModProduct [Branch _ [Guard test expr]] | isExprTrue test + = withTailMod [expr] +withTailModProduct _ = withNonTail + +withTailMod :: [Expr] -> Chk a -> Chk a +withTailMod modExpr + = withInput (\st -> st { isTailContext = isTailContext st && all isModCons modExpr }) + +isModCons :: Expr -> Bool +isModCons expr + = case expr of + Var _ _ -> True + TypeLam _ e -> isModCons e + TypeApp e _ -> isModCons e + Con _ _ -> True + Lit _ -> True + Let dgs e -> all isModConsDef (flattenDefGroups dgs) && isModCons e + App f args -> isModConsFun f && all isModCons args + _ -> False + +-- | Functions with non-observable execution can be moved before the mod-cons call. +-- This is necessary for various casts introduced in the effect checker. +isModConsFun :: Expr -> Bool +isModConsFun expr + = case expr of + TypeLam _ e -> isModConsFun e + TypeApp e _ -> isModConsFun e + Con _ _ -> True + Let dgs e -> all isModConsDef (flattenDefGroups dgs) && isModConsFun e + App f args -> hasTotalEffect (typeOf expr) && isModConsFun f && all isModCons args + _ -> False + +isModConsDef def = isModCons (defExpr def) + +withBorrowed :: S.Set Name -> Chk a -> Chk a +withBorrowed names action + = withInput (\st -> st { delta = S.union names (delta st) }) action + +isBorrowed :: TName -> Chk Bool +isBorrowed nm + = do st <- getInput + pure $ getName nm `S.member` delta st + +markSeen :: TName -> VarInfo -> Chk () +markSeen tname info | infoIsRefCounted info -- is locally defined? + = do isHeapValue <- needsDupDrop tname + when isHeapValue $ + writeOutput (Output (M.singleton tname 1) M.empty Leaf) +markSeen tname info = chkWrap tname info -- wrap rule + +markBorrowed :: TName -> VarInfo -> Chk () +markBorrowed nm info + = do b <- isBorrowed nm + unless b $ do + markSeen nm info + isHeapValue <- needsDupDrop nm + when (isHeapValue && infoIsRefCounted info) $ + requireCapability mayDealloc $ \ppenv -> Just $ + text "the last use of" <+> ppName ppenv (getName nm) <+> text "is borrowed (causing deallocation)" + +getAllocation :: TName -> Int -> Chk () +getAllocation nm 0 = pure () +getAllocation nm size + = do id <- lift $ lift $ uniqueId "alloc" + writeOutput (Output mempty (M.singleton size [(1 % 1, [(nm,id)])]) (Alloc id)) + +provideToken :: TName -> Int -> Output -> Chk Output +provideToken _ 0 out = pure out +provideToken debugName size out + = do requireCapability mayDealloc $ \ppenv -> + let fittingAllocs = M.findWithDefault [] size (gammaDia out) in + case fittingAllocs of + [] -> Just $ text "the matched constructor" <+> prettyCon ppenv debugName size <+> text "is not reused" + ((r, _):_) | r /= 1%1 -> + Just $ text "not all branches can reuse the space provided by" <+> prettyCon ppenv debugName size + _ -> Nothing + pure $ out { gammaDia = M.update (fmap snd . uncons) size (gammaDia out) } + +joinContexts :: [[Pattern]] -> [Output] -> Chk Output +joinContexts _ [] = pure mempty +joinContexts pats cs + = do let unionNm = foldl1' (M.unionWith max) (map gammaNm cs) + (noDealloc, cs') <- fmap unzip $ forM cs $ \c -> do + let unused = M.difference unionNm (gammaNm c) + (allReusable, c') <- foldM tryReuse (True, c) (map fst $ M.toList unused) + pure (allReusable, c') + unless (and noDealloc) $ do + requireCapability mayDealloc $ \ppenv -> Just $ + vcat $ text "not all branches use the same variables:" + : zipWith (\ps out -> cat [tupled (map (prettyPat ppenv) ps), text " -> ", prettyGammaNm ppenv out]) pats cs + let unionDia = foldl1' (M.unionWith zipTokens) $ map (M.map (adjustProb (length cs')) . gammaDia) cs' + pure (Output unionNm unionDia (Match (map allocTree cs'))) + where + adjustProb n xs = map (\(p, x) -> (p / (n%1), x) ) xs + + zipTokens ((px, x):xs) ((py, y):ys) = (px + py, x ++ y) : zipTokens xs ys + zipTokens xs [] = xs + zipTokens [] ys = ys + + tryReuse (allReusable, out) tname + = do mOut <- tryDropReuse tname out + isHeapVal <- needsDupDrop tname + pure $ case mOut of + Nothing -> (allReusable && not isHeapVal, out) + Just out -> (allReusable, out) + + prettyPat ppenv (PatCon nm [] _ _ _ _ _ _) = ppName ppenv (getName nm) + prettyPat ppenv (PatCon nm pats _ _ _ _ _ _) = ppName ppenv (getName nm) <.> tupled (map (prettyPat ppenv) pats) + prettyPat ppenv (PatVar nm PatWild) = ppName ppenv (getName nm) + prettyPat ppenv (PatVar nm pat) = cat [ppName ppenv (getName nm), text " as ", prettyPat ppenv pat] + prettyPat ppenv (PatLit l) = text $ show l + prettyPat ppenv PatWild = text "_" + +tryDropReuse :: TName -> Output -> Chk (Maybe Output) +tryDropReuse nm out + = do newtypes <- getNewtypes + platform <- getPlatform + case getFixedDataAllocSize platform newtypes (tnameType nm) of + Nothing -> pure Nothing + Just (sz, _) -> Just <$> provideToken nm sz out + +bindName :: TName -> Maybe Int -> Output -> Chk Output +bindName nm msize out + = do newtypes <- getNewtypes + platform <- getPlatform + out <- case M.lookup nm (gammaNm out) of + Nothing -- unused, so available for drop-guided reuse! + -> do mOut <- tryDropReuse nm out + case (msize, mOut) of + (Just sz, _) -> provideToken nm sz out + (_, Just out) -> pure out + (Nothing, Nothing) -> do + isHeapValue <- needsDupDrop nm + when isHeapValue $ + requireCapability mayDealloc $ \ppenv -> Just $ + text "the variable" <+> ppName ppenv (getName nm) <+> text "is unused (causing deallocation)" + pure out + Just n + -> do isHeapVal <- needsDupDrop nm + when (n > 1 && isHeapVal) $ + requireCapability mayAlloc $ \ppenv -> Just $ + text "the variable" <+> ppName ppenv (getName nm) <+> text "is used multiple times (causing sharing and preventing reuse)" + pure out + pure (out { gammaNm = M.delete nm (gammaNm out) }) + +-- | We record if the program has both an allocation +-- and a self-call which may be executed in sequence. +-- If that is the case, the program may use unlimited allocation. +data AllocInLoop = AllocInLoop + { hasAlloc :: Bool, + hasSelfCall :: Bool, + hasBothInSequence :: Bool } + +-- | Sequential composition +instance Semigroup AllocInLoop where + AllocInLoop a s b <> AllocInLoop a' s' b' + = AllocInLoop (a || a') (s || s') + (b || b' || (a && s') || (a' && s)) + +instance Monoid AllocInLoop where + mempty = AllocInLoop False False False + +-- | Non-sequential composition +joinBranches :: AllocInLoop -> AllocInLoop -> AllocInLoop +joinBranches (AllocInLoop a s b) (AllocInLoop a' s' b') + = AllocInLoop (a || a') (s || s') (b || b') + +getAllocCredits :: S.Set Id -> AllocTree -> (FipAlloc, AllocInLoop) +getAllocCredits notReused tree + = case tree of + Alloc id | id `S.member` notReused -> (AllocAtMost 1, mempty { hasAlloc = True }) + | otherwise -> mempty + Call alloc -> (alloc, mempty) + CallSelf alloc -> (alloc, mempty { hasSelfCall = True }) + Seq a1 a2 -> getAllocCredits notReused a1 <> getAllocCredits notReused a2 + Match as -> foldl' (\(a, b) (a', b') -> (max a a', joinBranches b b')) mempty (map (getAllocCredits notReused) as) + Leaf -> mempty + +prettyFipAlloc :: FipAlloc -> String +prettyFipAlloc f + = case f of + AllocAtMost 0 -> "nothing" + AllocAtMost n -> "at most " ++ show n + AllocFinitely -> "a finite amount" + AllocUnlimited -> "unlimited" + +checkOutputEmpty :: Output -> Chk () +checkOutputEmpty out + = do case M.maxViewWithKey $ gammaNm out of + Nothing -> pure () + Just ((nm, _), _) + -> emitWarning $ \penv -> text "unbound name (which may have been used despite being borrowed):" <+> ppName penv (getName nm) + let notReused = S.fromList $ map snd $ concatMap snd $ concatMap snd $ M.toList $ gammaDia out + (allocations, allocInLoop) = getAllocCredits notReused (allocTree out) + allocations' = if hasBothInSequence allocInLoop then AllocUnlimited else allocations + -- chkTrace $ show notReused + -- chkTrace $ show $ simplifyAllocTree (allocTree out) + permission <- fipAlloc <$> getFip + unless (allocations' <= permission) $ + emitWarning $ \penv -> text "function allocates" + <+> text (prettyFipAlloc allocations') + <+> text "but was declared as allocating" + <+> text (prettyFipAlloc permission) + +simplifyAllocTree :: AllocTree -> AllocTree +simplifyAllocTree (Seq a b) + = case (simplifyAllocTree a, simplifyAllocTree b) of + (Leaf, b) -> b + (a, Leaf) -> a + (a, b) -> Seq a b +simplifyAllocTree (Match as) = Match (map simplifyAllocTree as) +simplifyAllocTree t = t + +zipParamInfo :: [ParamInfo] -> [b] -> [(ParamInfo, b)] +zipParamInfo xs = zip (xs ++ repeat Own) + +-- value types with reference fields still need a drop +needsDupDrop :: TName -> Chk Bool +needsDupDrop tname | isCCtxName (getName tname) = return False -- ignore generated contexts +needsDupDrop tname + = do let tp = tnameType tname + mbdi <- getDataInfo tp + return $ + case mbdi of + Nothing -> True + Just di -> case dataInfoDef di of + DataDefValue vrepr | valueReprIsRaw vrepr -> False + _ -> if dataInfoName di == nameTpInt -- ignore special types (just `int` for now) + then False + else True + +getDataInfo :: Type -> Chk (Maybe DataInfo) +getDataInfo tp + = do newtypes <- getNewtypes + return (getDataInfo' newtypes tp) + +getNewtypes :: Chk Newtypes +getNewtypes = newtypes <$> getEnv + +getPlatform :: Chk Platform +getPlatform = platform <$> getEnv + +-- track the current definition for nicer error messages +withCurrentDef :: Def -> Chk a -> Chk a +withCurrentDef def action + = -- trace ("checking: " ++ show (defName def)) $ + withEnv (\env -> env{currentDef = def:currentDef env}) $ + action + +currentDefNames :: Chk [Name] +currentDefNames + = do env <- getEnv + return (map defName (currentDef env)) + +-- | Return borrowing infos for a name. May return the empty list +-- if no borrowing takes place. +getParamInfos :: Name -> Chk [ParamInfo] +getParamInfos name + = do b <- borrowed <$> getEnv + case borrowedLookup name b of + Nothing -> return [] + Just pinfos -> return pinfos + +traceDoc :: (Pretty.Env -> Doc) -> Chk () +traceDoc f + = do env <- getEnv + chkTrace (show (f (prettyEnv env))) + +chkTrace :: String -> Chk () +chkTrace msg + = do env <- getEnv + trace ("chk: " ++ show (map defName (currentDef env)) ++ ": " ++ msg) $ return () + +emitDoc :: Range -> Doc -> Chk () +emitDoc rng doc = tell (mempty, [(rng,doc)]) + +emitWarning :: (Pretty.Env -> Doc) -> Chk () +emitWarning makedoc + = do env <- getEnv + let (rng,name) = case currentDef env of + (def:_) -> (defNameRange def, defName def) + _ -> (rangeNull, nameNil) + penv = prettyEnv env + fdoc = text "fip fun" <+> ppName penv name <.> colon <+> makedoc penv + emitDoc rng fdoc + +getConstructorAllocSize :: ConRepr -> Chk Int +getConstructorAllocSize conRepr + = do platform <- getPlatform + return (conReprAllocSize platform conRepr) diff --git a/src/Core/Core.hs b/src/Core/Core.hs index 320e33ec4..5bc14bd2f 100644 --- a/src/Core/Core.hs +++ b/src/Core/Core.hs @@ -66,10 +66,13 @@ module Core.Core ( -- Data structures , isConSingleton , isConNormal , isConIso, isConAsJust + , conReprHasCtxPath, conReprCtxPath, CtxPath(..) , isDataStruct, isDataAsMaybe, isDataStructAsMaybe + , conReprAllocSize, conReprAllocSizeScan, conReprScanCount , getDataRepr, getDataReprEx, dataInfoIsValue , getConRepr , dataReprIsValue, conReprIsValue + , needsTagField , VarInfo(..), isInfoArity , infoIsRefCounted, infoIsLocal @@ -120,7 +123,7 @@ import Common.Id import Common.Error import Common.NamePrim( nameTrue, nameFalse, nameTuple, nameTpBool, nameEffectOpen, nameReturn, nameTrace, nameLog, nameEvvIndex, nameOpenAt, nameOpenNone, nameInt32, nameSSizeT, nameBox, nameUnbox, - nameVector, nameCons, nameNull, nameTpList, nameUnit, nameTpUnit, nameTpCField, + nameVector, nameCons, nameNull, nameTpList, nameUnit, nameTpUnit, nameTpFieldAddr, isPrimitiveName, isSystemCoreName, nameKeep, nameDropSpecial) import Common.Syntax import Kind.Kind @@ -141,7 +144,7 @@ isExprFalse (Con tname _) = (getName tname == nameFalse) isExprFalse _ = False exprUnit :: Expr -exprUnit = Con (TName nameUnit typeUnit) (ConEnum nameTpUnit DataEnum 0) +exprUnit = Con (TName nameUnit typeUnit) (ConEnum nameTpUnit DataEnum valueReprZero 0) -- (ConInfo nameUnit typeUnit [] [] [] (TFun [] typeTotal typeUnit) Inductive rangeNull [] [] False Public "") (patFalse,exprFalse) = patExprBool nameFalse 0 @@ -149,8 +152,9 @@ exprUnit = Con (TName nameUnit typeUnit) (ConEnum nameTpUnit DataEnum 0) patExprBool name tag = let tname = TName name typeBool - conEnum = ConEnum nameTpBool DataEnum tag - conInfo = ConInfo name nameTpBool [] [] [] (TFun [] typeTotal typeBool) Inductive rangeNull [] [] False Public "" + conEnum = ConEnum nameTpBool DataEnum valueReprZero tag + conInfo = ConInfo name nameTpBool [] [] [] (TFun [] typeTotal typeBool) Inductive rangeNull [] [] False + [] valueReprZero Public "" pat = PatCon tname [] conEnum [] [] typeBool conInfo False expr = Con tname conEnum in (pat,expr) @@ -174,10 +178,10 @@ makeList tp exprs = foldr cons nil exprs where nilTp = TForall [a] [] (TApp typeList [TVar a]) - nilCon = Con (TName nameNull nilTp) (ConSingleton nameTpList DataAsList 0) + nilCon = Con (TName nameNull nilTp) (ConSingleton nameTpList DataAsList valueReprZero 0) nil = TypeApp nilCon [tp] consTp = TForall [a] [] (typeFun [(nameNil,TVar a),(nameNil,TApp typeList [TVar a])] typeTotal (TApp typeList [TVar a])) - consCon = Con (TName nameCons consTp) (ConAsCons nameTpList DataAsList nameNull 2) -- NOTE: depends on Cons being second in the definition in std/core :-( + consCon = Con (TName nameCons consTp) (ConAsCons nameTpList DataAsList (valueReprScan 2) nameNull CtxNone 2) -- NOTE: depends on Cons being second in the definition in std/core :-( cons expr xs = App (TypeApp consCon [tp]) [expr,xs] a = TypeVar (0) kindStar Bound @@ -275,9 +279,10 @@ data External = External{ externalName :: Name , externalType :: Scheme , externalParams :: [ParamInfo] , externalFormat :: [(Target,String)] - , externalVis' :: Visibility + , externalVis' :: Visibility + , externalFip :: Fip , externalRange :: Range - , externalDoc :: String + , externalDoc :: String } | ExternalImport { externalImport :: [(Target,[(String,String)])] , externalRange :: Range } @@ -361,21 +366,24 @@ data DataRepr = -- value types | DataOpen deriving (Eq,Ord,Show) -data ConRepr = ConEnum{ conTypeName :: Name, conDataRepr :: DataRepr, conTag :: Int } -- part of enumeration (none has fields) - | ConIso{ conTypeName:: Name, conDataRepr :: DataRepr, conTag :: Int } -- one constructor with one field - | ConSingleton{ conTypeName :: Name, conDataRepr :: DataRepr, conTag :: Int } -- constructor without fields (and not part of an enum) - | ConSingle{ conTypeName :: Name, conDataRepr :: DataRepr, conTag :: Int } -- there is only one constructor and it is not iso or singleton (and this is it) - | ConAsJust{ conTypeName :: Name, conDataRepr :: DataRepr, conAsNothing :: Name, conTag :: Int } -- constructor is the just node of a maybe-like datatype (only use for DataAsMaybe, not for DataStructAsMaybe) - | ConStruct{ conTypeName :: Name, conDataRepr :: DataRepr, conTag :: Int } -- constructor as value type - | ConAsCons{ conTypeName :: Name, conDataRepr :: DataRepr, conAsNil :: Name, conTag :: Int } -- constructor is the cons node of a list-like datatype (may have one or more fields) - | ConOpen { conTypeName :: Name, conDataRepr :: DataRepr } -- constructor of open data type - | ConNormal{ conTypeName :: Name, conDataRepr :: DataRepr, conTag :: Int } -- a regular constructor +data ConRepr = ConEnum{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- part of enumeration (none has fields) + | ConIso{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- one constructor with one field + | ConSingleton{conTypeName::Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- constructor without fields (and not part of an enum) + | ConSingle{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: CtxPath, conTag :: Int } -- there is only one constructor and it is not iso or singleton (and this is it) + | ConAsJust{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conAsNothing :: Name, conTag :: Int } -- constructor is the just node of a maybe-like datatype (only use for DataAsMaybe, not for DataStructAsMaybe) + | ConStruct{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conTag :: Int } -- constructor as value type + | ConAsCons{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conAsNil :: Name, conCtxPath :: CtxPath, conTag :: Int } -- constructor is the cons node of a list-like datatype (may have one or more fields) + | ConOpen { conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: CtxPath } -- constructor of open data type + | ConNormal{ conTypeName :: Name, conDataRepr :: DataRepr, conValRepr :: ValueRepr, conCtxPath :: CtxPath, conTag :: Int } -- a regular constructor deriving (Eq,Ord,Show) -isConSingleton (ConSingleton _ _ _) = True +data CtxPath = CtxNone | CtxField TName + deriving(Eq,Ord,Show) + +isConSingleton (ConSingleton{}) = True isConSingleton _ = False -isConNormal (ConNormal _ _ _) = True +isConNormal (ConNormal{}) = True isConNormal _ = False isConIso (ConIso{}) = True @@ -393,10 +401,46 @@ isDataStructAsMaybe _ = False isConAsJust (ConAsJust{}) = True isConAsJust _ = False +conReprHasCtxPath :: ConRepr -> Bool +conReprHasCtxPath repr + = case conReprCtxPath repr of + Nothing -> False + _ -> True + +conReprCtxPath :: ConRepr -> Maybe CtxPath +conReprCtxPath repr | conReprIsValue repr = Nothing +conReprCtxPath repr + = case repr of + ConSingle{ conCtxPath = cpath } -> Just cpath + ConAsCons{ conCtxPath = cpath } -> Just cpath + ConNormal{ conCtxPath = cpath } -> Just cpath + ConOpen{ conCtxPath = cpath } -> Just cpath + _ -> Nothing + + +conReprScanCount :: ConRepr -> Int +conReprScanCount conRepr = valueReprScanCount (conValRepr conRepr) + +-- Return the allocation size (0 for value types) +conReprAllocSize :: Platform -> ConRepr -> Int +conReprAllocSize platform conRepr = fst (conReprAllocSizeScan platform conRepr) + +-- Return the allocation size (0 for value types) and scan count +conReprAllocSizeScan :: Platform -> ConRepr -> (Int,Int) +conReprAllocSizeScan platform conRepr + = let (size,scan) = valueReprSizeScan platform (conValRepr conRepr) + in if (conReprIsValue conRepr) then (0,scan) else (size,scan) + -- Value data is not heap allocated and needs no header dataReprIsValue :: DataRepr -> Bool dataReprIsValue drepr = (drepr <= DataStruct) +-- explicit tag field? +needsTagField :: DataRepr -> Bool +needsTagField DataStruct = True +needsTagField DataStructAsMaybe = True +needsTagField rep = False + conReprIsValue :: ConRepr -> Bool conReprIsValue crepr = dataReprIsValue (conDataRepr crepr) @@ -424,25 +468,26 @@ getDataReprEx getIsValue info isValue = getIsValue info && not (dataInfoIsRec info) (dataRepr,conReprFuns) = if (dataInfoIsOpen(info)) - then (DataOpen, map (\conInfo conTag -> ConOpen typeName DataOpen) conInfos) + then (DataOpen, map (\conInfo conTag -> ConOpen typeName DataOpen (conInfoValueRepr conInfo) CtxNone) conInfos) -- TODO: only for C#? check this during kind inference? -- else if (hasExistentials) -- then (DataNormal, map (\con -> ConNormal typeName) conInfos) else if (isValue - && (null (dataInfoParams info) || typeName == nameTpCField) + && (null (dataInfoParams info) || typeName == nameTpFieldAddr) && all (\con -> null (conInfoParams con)) conInfos) - then (DataEnum,map (const (ConEnum typeName DataEnum)) conInfos) + then (DataEnum,map (\ci -> ConEnum typeName DataEnum (conInfoValueRepr ci)) conInfos) else if (length conInfos == 1) - then let conInfo = head conInfos + then let conInfo = head conInfos + valRepr = conInfoValueRepr conInfo dataRepr = if (isValue && length (conInfoParams conInfo) == 1) then DataIso else if (isValue && null singletons && not (dataInfoIsRec info)) then DataSingleStruct else DataSingle (not (null singletons)) in (dataRepr - ,[if (isValue && length (conInfoParams conInfo) == 1) then ConIso typeName dataRepr - else if length singletons == 1 then ConSingleton typeName dataRepr - else ConSingle typeName dataRepr]) + ,[if (isValue && length (conInfoParams conInfo) == 1) then ConIso typeName dataRepr valRepr + else if length singletons == 1 then ConSingleton typeName dataRepr valRepr + else ConSingle typeName dataRepr valRepr CtxNone]) else if (isValue && not (dataInfoIsRec info)) then ( let dataRepr = if (length conInfos == 2 && length singletons == 1 && case (filter (\cinfo -> length (conInfoParams cinfo) == 1) conInfos) of -- at most 1 field @@ -450,8 +495,8 @@ getDataReprEx getIsValue info _ -> False) then DataStructAsMaybe else DataStruct - in (dataRepr, map (\con -> if null (conInfoParams con) then ConSingleton typeName dataRepr - else ConStruct typeName dataRepr) conInfos) + in (dataRepr, map (\ci -> if null (conInfoParams ci) then ConSingleton typeName dataRepr (conInfoValueRepr ci) + else ConStruct typeName dataRepr (conInfoValueRepr ci)) conInfos) ) else ( if (length conInfos == 2 && length singletons == 1) @@ -466,20 +511,20 @@ getDataReprEx getIsValue info in (if isMaybeLike then (DataAsMaybe - ,map (\con -> if (null (conInfoParams con)) then ConSingleton typeName DataAsMaybe - else ConAsJust typeName DataAsMaybe (conInfoName (head singletons))) conInfos) + ,map (\ci -> if (null (conInfoParams ci)) then ConSingleton typeName DataAsMaybe (conInfoValueRepr ci) + else ConAsJust typeName DataAsMaybe (conInfoValueRepr ci) (conInfoName (head singletons))) conInfos) else (DataAsList - ,map (\con tag - -> if (null (conInfoParams con)) then ConSingleton typeName DataAsList tag - else ConAsCons typeName DataAsList (conInfoName (head singletons)) tag) conInfos) + ,map (\ci tag + -> if (null (conInfoParams ci)) then ConSingleton typeName DataAsList (conInfoValueRepr ci) tag + else ConAsCons typeName DataAsList (conInfoValueRepr ci) (conInfoName (head singletons)) CtxNone tag) conInfos) ) else let dataRepr = if (length singletons == length conInfos -1 || null conInfos) then DataSingleNormal else (DataNormal (not (null singletons))) in (dataRepr - ,map (\con -> if null (conInfoParams con) - then ConSingleton typeName dataRepr - else ConNormal typeName dataRepr) conInfos + ,map (\ci -> if null (conInfoParams ci) + then ConSingleton typeName dataRepr (conInfoValueRepr ci) + else ConNormal typeName dataRepr (conInfoValueRepr ci) CtxNone) conInfos ) ) in (dataRepr, [conReprFun tag | (conReprFun,tag) <- zip conReprFuns [1..]]) @@ -537,14 +582,14 @@ data InlineDef = InlineDef{ defIsVal :: Def -> Bool defIsVal def = case defSort def of - DefFun _ -> False + DefFun{} -> False _ -> True defParamInfos :: Def -> [ParamInfo] defParamInfos def = case defSort def of - DefFun pinfos -> pinfos - _ -> [] + DefFun pinfos _ -> pinfos + _ -> [] inlineDefIsSpecialize :: InlineDef -> Bool inlineDefIsSpecialize inlDef = not (null (inlineParamSpecialize inlDef)) @@ -564,11 +609,11 @@ instance Functor CorePhase where return (CPState (f x) uniq' defs')) instance Applicative CorePhase where - pure = return - (<*>) = ap + pure x = CP (\uniq defs -> return (CPState x uniq defs)) + (<*>) = ap instance Monad CorePhase where - return x = CP (\uniq defs -> return (CPState x uniq defs)) + -- return = pure (CP cp) >>= f = CP (\uniq defs -> do (CPState x uniq' defs') <- cp uniq defs case f x of CP cp' -> cp' uniq' defs') @@ -666,7 +711,7 @@ data VarInfo | InfoArity Int Int -- #Type parameters, #parameters | InfoExternal [(Target,String)] -- inline body | InfoReuse Pattern - | InfoConField TName Name -- constructor name, field name + | InfoConField TName ConRepr Name -- constructor name, repr, field name (inserted by reuse specialization) data TName = TName { getName :: Name @@ -697,7 +742,7 @@ instance Show VarInfo where -> "" InfoReuse pat -> "reuse:" - InfoConField conName fieldName + InfoConField conName conRepr fieldName -> "field:" ++ show conName ++ "." ++ show fieldName InfoArity m n -> "arity:" ++ show (m,n) @@ -1052,7 +1097,7 @@ addLambdasTName pars eff e = Lam pars eff e -- | Bind a variable inside a term addNonRec :: Name -> Type -> Expr -> (Expr -> Expr) addNonRec x tp e e' - = Let [DefNonRec (Def x tp e Private (if isValueExpr e then DefVal else DefFun [] {-all owned?-}) InlineAuto rangeNull "")] e' + = Let [DefNonRec (Def x tp e Private (if isValueExpr e then DefVal else defFun [] {-all owned?-}) InlineAuto rangeNull "")] e' -- | Is an expression a value or a function isValueExpr :: Expr -> Bool @@ -1210,7 +1255,7 @@ extractSignatures core extractExternals (coreProgExternals core), extractDefs (coreProgDefs core) ] - in -- trace ("extract signatures: " ++ show (map pretty tps)) $ + in -- trace ("extract signatures: " ++ show (map pretty tps)) $ tps where extractExternals = concatMap extractExternal diff --git a/src/Core/Divergent.hs b/src/Core/Divergent.hs index da3aad47c..b1ee0f01d 100644 --- a/src/Core/Divergent.hs +++ b/src/Core/Divergent.hs @@ -104,11 +104,11 @@ instance Functor Div where fmap f (Div d) = Div (\rel -> case d rel of (x,calls) -> (f x, calls)) instance Applicative Div where - pure = return - (<*>) = ap + pure x = Div (\rel -> (x,[])) + (<*>) = ap instance Monad Div where - return x = Div (\rel -> (x,[])) + -- return = pure (Div d) >>= f = Div (\rel -> case d rel of (x,calls1) -> case f x of Div d2 -> case d2 rel of diff --git a/src/Core/FunLift.hs b/src/Core/FunLift.hs index 490f36fdb..25e0c8a41 100644 --- a/src/Core/FunLift.hs +++ b/src/Core/FunLift.hs @@ -136,7 +136,7 @@ liftDef topLevel def return def{ defExpr = expr', defSort = liftSort topLevel (defSort def)} liftSort :: Bool -> DefSort -> DefSort -liftSort False (DefFun _) = DefVal +liftSort False (DefFun{}) = DefVal liftSort _ sort = sort {- @@ -320,11 +320,11 @@ instance Functor Lift where Ok x st' dgs -> Ok (f x) st' dgs) instance Applicative Lift where - pure = return + pure x = Lift (\env st -> Ok x st []) (<*>) = ap instance Monad Lift where - return x = Lift (\env st -> Ok x st []) + -- return = pure (Lift c) >>= f = Lift (\env st -> case c env st of Ok x st' dgs -> case f x of Lift d -> case d env st' of diff --git a/src/Core/GenDoc.hs b/src/Core/GenDoc.hs index 7f84755f2..b0ea0674c 100644 --- a/src/Core/GenDoc.hs +++ b/src/Core/GenDoc.hs @@ -184,7 +184,7 @@ genDoc env kgamma gamma core p = map toDef (coreProgExternals core) where toDef ext = Def (externalName ext) (externalType ext) (failure "Core.GenDoc.genDoc: access to expression") - (externalVis ext) (DefFun (externalParams ext)) InlineAuto (externalRange ext) (externalDoc ext) + (externalVis ext) (defFun (externalParams ext)) InlineAuto (externalRange ext) (externalDoc ext) htmlBody pre = do mapM_ (writeLn p) (htmlHeader env (show (coreProgName core))) diff --git a/src/Core/Inline.hs b/src/Core/Inline.hs index a8e82b9b0..be7bb9ce4 100644 --- a/src/Core/Inline.hs +++ b/src/Core/Inline.hs @@ -7,7 +7,9 @@ ----------------------------------------------------------------------------- ----------------------------------------------------------------------------- --- Inl all local and anonymous functions to top level. No more letrec :-) +-- Inline top-level functions (across modules) +-- Does not inline recursive top-level functions, that is done by specialization +-- (See Core/Specialize). ----------------------------------------------------------------------------- module Core.Inline( inlineDefs @@ -101,8 +103,8 @@ inlExpr expr -- Applications App (TypeApp f targs) args -> do f0 <- inlExpr f - f' <- inlAppExpr f0 (length targs) (length args) (onlyZeroCost args) args' <- mapM inlExpr args + f' <- inlAppExpr f0 (length targs) (argLength args) (onlyZeroCost args) return (App (TypeApp f' targs) args') App f args @@ -150,9 +152,6 @@ inlExpr expr inlAppExpr :: Expr -> Int -> Int -> Bool -> Inl Expr inlAppExpr expr m n onlyZeroCost = case expr of - App eopen@(TypeApp (Var open info) targs) [f] | getName open == nameEffectOpen - -> do (f') <- inlAppExpr f m n onlyZeroCost - return (App eopen [f']) Var tname varInfo -> do mbInfo <- inlLookup (getName tname) case mbInfo of @@ -168,6 +167,15 @@ inlAppExpr expr m n onlyZeroCost return (expr) Nothing -> do traceDoc $ \penv -> text "not inline candidate:" <+> text (showTName tname) return (expr) + -- handle .open(f) calls + TypeApp f targs | m == 0 -- can happen if it is inside an open as: .open<..>(f<..>) (test: cgen/inline4) + -> do f' <- inlAppExpr f (length targs) n onlyZeroCost + return (TypeApp f' targs) + App eopen@(TypeApp (Var open info) targs) [f] | getName open == nameEffectOpen + -> do -- traceDoc $ \penv -> text "go through open:" <+> text (show (m,n)) + f' <- inlAppExpr f m n onlyZeroCost + return (App eopen [f']) + _ -> return (expr) -- no inlining @@ -207,11 +215,11 @@ instance Functor Inl where Ok x st' -> Ok (f x) st') instance Applicative Inl where - pure = return - (<*>) = ap + pure x = Inl (\env st -> Ok x st) + (<*>) = ap instance Monad Inl where - return x = Inl (\env st -> Ok x st) + -- return = pure (Inl c) >>= f = Inl (\env st -> case c env st of Ok x st' -> case f x of Inl d -> d env st' ) @@ -268,9 +276,15 @@ inlLookup name traceDoc :: (Pretty.Env -> Doc) -> Inl () traceDoc f = do env <- getEnv - inlTrace (show (f (prettyEnv env))) + inlTrace (show (f (prettyEnv env))) inlTrace :: String -> Inl () inlTrace msg = do env <- getEnv trace ("inl: " ++ show (map defName (currentDef env)) ++ ": " ++ msg) $ return () + +verboseDoc :: (Pretty.Env -> Doc) -> Inl () +verboseDoc f + = do env <- getEnv + when (verbose (prettyEnv env) >= 3) $ + traceDoc f diff --git a/src/Core/Monadic.hs b/src/Core/Monadic.hs index 494b502db..db1e87470 100644 --- a/src/Core/Monadic.hs +++ b/src/Core/Monadic.hs @@ -377,11 +377,11 @@ instance Functor Mon where Ok x st' -> Ok (f x) st') instance Applicative Mon where - pure = return - (<*>) = ap + pure x = Mon (\env st -> Ok x st) + (<*>) = ap instance Monad Mon where - return x = Mon (\env st -> Ok x st) + -- return = pure (Mon c) >>= f = Mon (\env st -> case c env st of Ok x st' -> case f x of Mon d -> d env st' ) diff --git a/src/Core/MonadicLift.hs b/src/Core/MonadicLift.hs index 184cd7f5f..58ab7cb0f 100644 --- a/src/Core/MonadicLift.hs +++ b/src/Core/MonadicLift.hs @@ -221,7 +221,7 @@ makeDef fvs tvs expr liftedFun = addTypeLambdas alltpars $ Lam allpars eff body liftedTp = -- trace ("makeDef: liftedFun: " ++ show (prettyExpr defaultEnv{coreShowTypes=True} expr) ++ "\nraw: " ++ show expr) $ typeOf liftedFun - liftedDef name inl = Def name liftedTp liftedFun Private (DefFun [] {-all owned-}) InlineAuto rangeNull "// monadic lift" + liftedDef name inl = Def name liftedTp liftedFun Private (defFun [] {-all owned-}) InlineAuto rangeNull "// monadic lift" funExpr name = Var (TName name liftedTp) (InfoArity (length alltpars) (length allargs)) @@ -288,11 +288,11 @@ instance Functor Lift where Ok x st' dgs -> Ok (f x) st' dgs) instance Applicative Lift where - pure = return - (<*>) = ap + pure x = Lift (\env st -> Ok x st []) + (<*>) = ap instance Monad Lift where - return x = Lift (\env st -> Ok x st []) + -- return = pure (Lift c) >>= f = Lift (\env st -> case c env st of Ok x st' dgs -> case f x of Lift d -> case d env st' of diff --git a/src/Core/Parse.hs b/src/Core/Parse.hs index 7d0f9ff38..a7ea9080e 100644 --- a/src/Core/Parse.hs +++ b/src/Core/Parse.hs @@ -264,9 +264,12 @@ conDecl tname foralls sort env -- trace ("core con: " ++ show name) $ return () (env1,existss) <- typeParams env (env2,params) <- parameters env1 + vrepr <- parseValueRepr tp <- typeAnnot env2 let params2 = [(if nameIsNil name then newFieldName i else name, tp) | ((name,tp),i) <- zip params [1..]] - let con = (ConInfo (qualify (modName env) name) tname foralls existss params2 tp sort rangeNull (map (const rangeNull) params2) (map (const Public) params2) False vis doc) + orderedFields = [] -- no need to reconstruct as it is only used during codegen? + let con = (ConInfo (qualify (modName env) name) tname foralls existss params2 tp sort rangeNull (map (const rangeNull) params2) (map (const Public) params2) False + orderedFields vrepr vis doc) -- trace (show con ++ ": " ++ show params2) $ return con @@ -286,16 +289,23 @@ parseTypeMod = do{ specialId "open"; return (DataDefOpen, False, Inductive) } <|> do{ specialId "extend"; return (DataDefOpen, True, Inductive) } <|> do specialId "value" - (m,n) <- braced $ do (m,_) <- integer - comma - (n,_) <- integer - return (m,n) - return (DataDefValue (fromInteger m) (fromInteger n), False, Inductive) + vrepr <- parseValueRepr + return (DataDefValue vrepr, False, Inductive) <|> do{ specialId "co"; return (DataDefNormal, False, CoInductive) } <|> do{ specialId "rec"; return (DataDefNormal, False, Retractive) } <|> return (DataDefNormal, False, Inductive) "" +parseValueRepr :: LexParser ValueRepr +parseValueRepr + = braced $ do (raw,_) <- integer + comma + (scan,_) <- integer + comma + (align,_) <- integer + return (ValueRepr (fromInteger raw) (fromInteger scan) (fromInteger align)) + + {-------------------------------------------------------------------------- Value definitions --------------------------------------------------------------------------} @@ -311,8 +321,8 @@ defDecl env keyword ":" (tp,pinfos) <- pdeftype env let sort = case sort0 of - DefFun _ -> DefFun pinfos - _ -> sort0 + DefFun _ fip -> DefFun pinfos fip + _ -> sort0 -- trace ("parse def: " ++ show name ++ ": " ++ show tp) $ return () return (Def (qualify (modName env) name) tp (error ("Core.Parse: " ++ show name ++ ": cannot get the expression from an interface core file")) vis sort inl rangeNull doc) @@ -320,13 +330,14 @@ defDecl env pdefSort = do isRec <- do{ specialId "recursive"; return True } <|> return False inl <- parseInline - (do (_,doc) <- dockeyword "fun" + (do fip <- try parseFip + (_,doc) <- dockeyword "fun" _ <- do { specialOp "**"; return ()} <|> do { specialOp "*"; return () } <|> return () - return (DefFun [],inl,isRec,doc) -- borrow info comes from type + return (defFunEx [] fip,inl,isRec,doc) -- borrow info comes from type <|> do (_,doc) <- dockeyword "val" return (DefVal,inl,False,doc)) @@ -336,15 +347,16 @@ pdefSort --------------------------------------------------------------------------} externDecl :: Env -> LexParser External externDecl env - = do (vis,doc) <- try $ do vis <- vispub - (_,doc) <- dockeyword "extern" - return (vis,doc) + = do (vis,fip,doc) <- try $ do vis <- vispub + fip <- parseFip + (_,doc) <- dockeyword "extern" + return (vis,fip,doc) (name,_) <- (funid) -- trace ("core def: " ++ show name) $ return () keyword ":" (tp,pinfos) <- pdeftype env formats <- externalBody - return (External (qualify (modName env) name) tp pinfos formats vis rangeNull doc) + return (External (qualify (modName env) name) tp pinfos formats vis fip rangeNull doc) externalBody :: LexParser [(Target,String)] @@ -427,8 +439,9 @@ inlineDefSort (s,_) <- stringLit return [if c == '^' then Borrow else Own | c <- s] <|> return [] - (do (_,doc) <- dockeyword "fun" - return (DefFun pinfos,inl,isRec,spec,doc) + (do fip <- try parseFip + (_,doc) <- dockeyword "fun" + return (DefFun pinfos fip,inl,isRec,spec,doc) <|> do (_,doc) <- dockeyword "val" return (DefVal,inl,False,spec,doc)) diff --git a/src/Core/Pretty.hs b/src/Core/Pretty.hs index c77b308ed..f131fca19 100644 --- a/src/Core/Pretty.hs +++ b/src/Core/Pretty.hs @@ -9,7 +9,7 @@ -} ----------------------------------------------------------------------------- -module Core.Pretty( prettyCore, prettyExpr, prettyPattern, prettyDef, prettyDefs, prettyDefGroup ) where +module Core.Pretty( prettyCore, prettyExpr, prettyPattern, prettyDef, prettyDefs, prettyDefGroup, keyword, source ) where import Lib.Trace import Data.Char( isAlphaNum ) @@ -38,6 +38,9 @@ prettyNames = True keyword env s = color (colorKeyword (colors env)) (text s) +source env doc + = color (colorSource (colors env)) doc + {-------------------------------------------------------------------------- Show instance declarations --------------------------------------------------------------------------} @@ -156,12 +159,12 @@ prettyImportedSyn env synInfo = ppSynInfo env True False True synInfo <.> semi prettyExternal :: Env -> External -> Doc -prettyExternal env (External name tp pinfos body vis nameRng doc) | coreIface env && isHiddenExternalName name +prettyExternal env (External name tp pinfos body vis fip nameRng doc) | coreIface env && isHiddenExternalName name = empty -prettyExternal env (External name tp pinfos body vis nameRng doc) +prettyExternal env (External name tp pinfos body vis fip nameRng doc) = prettyComment env doc $ prettyVis env vis $ - keyword env "extern" <+> prettyDefName env name <+> text ":" <+> prettyDefFunType env pinfos tp <+> prettyEntries body + keyword env (show fip ++ "extern") <+> prettyDefName env name <+> text ":" <+> prettyDefFunType env pinfos tp <+> prettyEntries body where prettyEntries [(Default,content)] = keyword env "= inline" <+> prettyLit env (LitString content) <.> semi prettyEntries entries = text "{" <-> tab (vcat (map prettyEntry entries)) <-> text "};" @@ -242,7 +245,7 @@ prettyInlineDef env (InlineDef name expr isRec inlkind cost sort specArgs) <.> (if (null specArgs) then empty else (keyword env "specialize " <.> prettySpecArgs <.> text " ")) <.> (if (cost <= 0 || inlkind == InlineAlways) then (keyword env "inline ") else empty) <.> prettyParamInfos sort - <.> keyword env (show sort) + <.> keyword env (defSortShowFull sort) <+> (if nameIsNil name then text "_" else prettyDefName env name) -- <+> text ":" <+> prettyType env scheme <+> text ("// inline size: " ++ show cost) @@ -256,7 +259,7 @@ prettyInlineDef env (InlineDef name expr isRec inlkind cost sort specArgs) prettySpecArgs = dquotes (text [if spec then '*' else '_' | spec <- specArgs]) - prettyParamInfos (DefFun pinfos) | Borrow `elem` pinfos + prettyParamInfos (DefFun{defFunParamInfos=pinfos}) | Borrow `elem` pinfos = keyword env "borrow" <+> dquotes (text [if info == Borrow then '^' else '_' | info <- pinfos]) <.> text " " prettyParamInfos _ = empty @@ -270,13 +273,13 @@ prettyDefX env isRec def@(Def name scheme expr vis sort inl nameRng doc) then ppBody <.> semi else -} prettyVis env vis $ - keyword env (show sort) + keyword env (defSortShowFull sort) <+> (if nameIsNil name && coreShowDef env then text "_" else prettyDefName env name) <+> text ":" <+> (case sort of - DefFun pinfos -> prettyDefFunType env pinfos scheme - _ -> prettyType env scheme + DefFun pinfos _ -> prettyDefFunType env pinfos scheme + _ -> prettyType env scheme ) <.> (if (not (coreShowDef env)) -- && (sizeDef def >= coreInlineMax env) then empty diff --git a/src/Core/Simplify.hs b/src/Core/Simplify.hs index 958e1f772..54339fc27 100644 --- a/src/Core/Simplify.hs +++ b/src/Core/Simplify.hs @@ -22,7 +22,9 @@ import Common.Syntax import Common.NamePrim( nameEffectOpen, nameToAny, nameReturn, nameOptionalNone, nameIsValidK , nameLift, nameBind, nameEvvIndex, nameClauseTailNoYield, isClauseTailName , nameBox, nameUnbox, nameAssert - , nameAnd, nameOr, isNameTuple ) + , nameAnd, nameOr, isNameTuple + , nameCCtxCompose, nameCCtxComposeExtend, nameCCtxEmpty ) + import Common.Unique import Type.Type import Type.Kind @@ -349,6 +351,19 @@ bottomUp (App (Lam pars eff body) args) | length pars == length args && all fre bottomUp (App (TypeApp (Var bind _) _) [App (TypeApp (Var lift _) _) [arg], cont]) | getName bind == nameBind && getName lift == nameLift = App cont [arg] + +-- composition extension: c[ctx hole] -> c +bottomUp (App (TypeApp (Var cextend _) _) [ctx1, App (TypeApp (Var cempty _) _) []]) | getName cextend == nameCCtxComposeExtend && getName cempty == nameCCtxEmpty + = ctx1 + +-- context composition: c ++ ctx _ == c == ctx _ ++ c +bottomUp (App (TypeApp (Var ctxcomp _) _) [ctx1, App (TypeApp (Var cempty _) _) []]) | getName ctxcomp == nameCCtxCompose && getName cempty == nameCCtxEmpty + = ctx1 + +bottomUp (App (TypeApp (Var ctxcomp _) _) [App (TypeApp (Var cempty _) _) [],ctx2]) | getName ctxcomp == nameCCtxCompose && getName cempty == nameCCtxEmpty + = ctx2 + + -- continuation validation bottomUp expr@(App (TypeApp (Var isValidK _) _) [arg]) | getName isValidK == nameIsValidK = case arg of @@ -436,7 +451,7 @@ bottomUp (App (Var v _) [App (Var w _) [arg]]) | (getName v == nameUnbox && get -- direct application of arguments to a lambda: fun(x1...xn) { f(x1,...,xn) } -> f -bottomUp (Lam pars eff (App f@(Var _ info) args)) | notExternal && length pars == length args && argsMatchPars +bottomUp (Lam pars eff (App f@(Var _ info) args)) | notExternal && length pars == length args && argsMatchPars = f where argsMatchPars = and (zipWith argMatchPar pars args) @@ -482,6 +497,7 @@ instance Applicative Match where NoMatch -> NoMatch instance Monad Match where + -- return = pure m >>= f = case m of Match x -> f x Unknown -> Unknown @@ -903,11 +919,11 @@ instance Functor Simp where fmap f (Simplify c) = Simplify (\u env -> case c u env of Ok x u' -> Ok (f x) u') instance Applicative Simp where - pure = return - (<*>) = ap + pure x = Simplify (\u g -> Ok x u) + (<*>) = ap instance Monad Simp where - return x = Simplify (\u g -> Ok x u) + -- return = pure (Simplify c) >>= f = Simplify (\u g -> case c u g of Ok x u' -> case f x of Simplify d -> d u' g) diff --git a/src/Core/Specialize.hs b/src/Core/Specialize.hs index 1bdd419e5..176fd655b 100644 --- a/src/Core/Specialize.hs +++ b/src/Core/Specialize.hs @@ -301,15 +301,17 @@ comment = unlines . map ("// " ++) . lines -- The important thing is that we don't try to get the type of the body at the same time as replacing the recursive calls -- since the type of the body depends on the type of the functions that it calls and vice versa replaceCall :: Name -> Expr -> DefSort -> [Bool] -> [Expr] -> Maybe [Type] -> SpecM Expr -replaceCall name expr sort bools args mybeTypeArgs +replaceCall name expr0 sort bools args mybeTypeArgs = do + expr <- uniquefyExprU expr0 + -- extract the specialized parameters let ((newParams, newArgs), (speccedParams, speccedArgs)) = (unzip *** unzip) -- $ (\x@(new, spec) -> trace ("Specializing to newArgs " <> show new) $ x) $ partitionBools bools $ zip (fnParams expr) args - + -- create a new (recursive) specialized body where the specialized parameters become local defitions let specBody0 = (\body -> case mybeTypeArgs of @@ -319,6 +321,7 @@ replaceCall name expr sort bools args mybeTypeArgs $ Let [DefNonRec $ Def param typ arg Private DefVal InlineAuto rangeNull "" -- bind specialized parameters | (TName param typ, arg) <- zip speccedParams speccedArgs] $ fnBody expr + -- substitute self-recursive calls to call our new specialized definition (without the specialized arguments!) specName <- uniqueName "spec" @@ -326,9 +329,10 @@ replaceCall name expr sort bools args mybeTypeArgs specTName = TName specName specType specBody = case specBody0 of Lam args eff (Let specArgs body) - -> uniquefyExpr $ + -> -- uniquefyExpr $ Lam args eff $ - (Let specArgs $ specInnerCalls (TName name (typeOf expr)) specTName bools speccedParams body) + (Let specArgs $ + specInnerCalls (TName name (typeOf expr)) specTName bools speccedParams body) _ -> failure "Specialize.replaceCall: Unexpected output from specialize pass" -- simplify so the new specialized arguments are potentially inlined unlocking potential further specialization @@ -438,7 +442,8 @@ recursiveCalls Def{ defName=thisDefName, defExpr=expr } -> go body TypeLam types (Lam params eff body) -> go body - _ -> failure "recursiveCalls: not a function" + -- _ -> (Nothing,[]) + _ -> failure ("Core.Specialize: recursiveCalls: not a function: " ++ show thisDefName ++ ": " ++ show expr) where go body = let (types, args) = unzip $ foldMapExpr f body diff --git a/src/Core/UnReturn.hs b/src/Core/UnReturn.hs index a29b456b6..0f18eb58a 100644 --- a/src/Core/UnReturn.hs +++ b/src/Core/UnReturn.hs @@ -209,7 +209,7 @@ urCase org scruts branches let f c = let lam = Lam [parName] eff (c parVar) defTp = typeOf lam - def = Def name defTp lam Private (DefFun [Own]) InlineAuto rangeNull "" + def = Def name defTp lam Private (defFun [Own]) InlineAuto rangeNull "" defVar = Var (TName name defTp) InfoNone -- (InfoArity 0 1 NoMon) -- with arity C# code gets wrong app e = App defVar [e] in makeLet [DefNonRec def] $ @@ -326,11 +326,11 @@ instance Functor UR where Ok x st' -> Ok (f x) st') instance Applicative UR where - pure = return - (<*>) = ap + pure x = UR (\env st -> Ok x st) + (<*>) = ap instance Monad UR where - return x = UR (\env st -> Ok x st) + -- return = pure (UR c) >>= f = UR (\env st -> case c env st of Ok x st' -> case f x of UR d -> d env st' ) diff --git a/src/Core/Uniquefy.hs b/src/Core/Uniquefy.hs index 61cc41a3a..888b9b4f4 100644 --- a/src/Core/Uniquefy.hs +++ b/src/Core/Uniquefy.hs @@ -11,7 +11,7 @@ module Core.Uniquefy ( uniquefy , uniquefyDefGroup {- used for divergence analysis -} - , uniquefyExpr + , uniquefyExpr, uniquefyExprWith, uniquefyExprU , uniquefyDefGroups {- used in inline -} ) where @@ -23,25 +23,32 @@ import qualified Common.NameMap as M import Core.Core import Core.CoreVar( freeLocals ) import Common.Failure +import Common.Unique type Locals = S.NameSet type Renaming = M.NameMap Name data Un a = Un (State -> (a,State)) -data State = St{ locals :: Locals, renaming :: Renaming } +data State = St{ locals :: Locals, renaming :: Renaming, uniq :: Int } instance Functor Un where fmap f (Un u) = Un (\st -> case u st of (x,st1) -> (f x,st1)) instance Applicative Un where - pure = return + pure x = Un (\st -> (x,st)) (<*>) = ap instance Monad Un where - return x = Un (\st -> (x,st)) + -- return = pure (Un u) >>= f = Un (\st0 -> case u st0 of (x,st1) -> case f x of Un u1 -> u1 st1) +instance HasUnique Un where + updateUnique f + = do st' <- updateSt (\st -> st{ uniq = f (uniq st)}) + return (uniq st') + + updateSt f = Un (\st -> (st,f st)) @@ -65,23 +72,40 @@ getRenaming = fmap renaming getSt setLocals l = updateSt (\st -> st{ locals = l }) setRenaming r = updateSt (\st -> st{ renaming = r }) -runUn (Un u) - = fst (u (St S.empty M.empty)) +makeFullUnique + = do st <- getSt + return (uniq st /= 0) + +runUn uniq (Un u) + = fst (u (St S.empty M.empty uniq)) uniquefyExpr :: Expr -> Expr uniquefyExpr expr - = let locals = S.map getName (freeLocals expr) - in runUn $ + = uniquefyExprWith tnamesEmpty expr + +uniquefyExprWith :: TNames -> Expr -> Expr +uniquefyExprWith free expr + = let locals = S.map getName (free `tnamesUnion` (freeLocals expr)) + in runUn 0 $ do setLocals locals uniquefyExprX expr +uniquefyExprU :: HasUnique m => Expr -> m Expr +uniquefyExprU expr + = withUnique $ \uniq0 -> + runUn uniq0 $ + do expr' <- uniquefyExprX expr + uniq1 <- unique + return (expr',uniq1) + + uniquefy :: Core -> Core uniquefy core = core{coreProgDefs = uniquefyDefGroups (coreProgDefs core) } uniquefyDefGroups :: [DefGroup] -> [DefGroup] uniquefyDefGroups dgs - = runUn $ + = runUn 0 $ do locals <- getLocals let toplevelDefs = filter (not . nameIsNil) (map defName (flattenDefGroups dgs)) setLocals (foldr (\name locs -> S.insert (unqualify name) locs) locals toplevelDefs) @@ -99,7 +123,7 @@ uniquefyDefGroups dgs uniquefyDefGroup :: DefGroup -> DefGroup uniquefyDefGroup defgroup - = runUn $ + = runUn 0 $ case defgroup of DefNonRec def -> fmap DefNonRec $ uniquefyDef def @@ -205,10 +229,13 @@ uniquefyName name | nameIsNil name = return name uniquefyName name = do locals <- getLocals - if (S.member name locals) + full <- makeFullUnique + if (full || S.member name locals) then do renaming <- getRenaming - let name1 = findUniqueName 0 name locals - locals1 = S.insert name1 locals + name1 <- if full + then uniqueNameFrom name + else return (findUniqueName 0 name locals) + let locals1 = S.insert name1 locals renaming1 = M.insert name name1 renaming setLocals locals1 setRenaming renaming1 diff --git a/src/Core/Unroll.hs b/src/Core/Unroll.hs new file mode 100644 index 000000000..69275b1e2 --- /dev/null +++ b/src/Core/Unroll.hs @@ -0,0 +1,261 @@ +----------------------------------------------------------------------------- +-- Copyright 2022, Microsoft Research, Daan Leijen +-- +-- This is free software; you can redistribute it and/or modify it under the +-- terms of the Apache License, Version 2.0. A copy of the License can be +-- found in the LICENSE file at the root of this distribution. +----------------------------------------------------------------------------- + +{---------------------------------------------------------------------------- +Unroll one level of (some) recursive functions: + + fun map( xs : list, f : a -> e b ) : e list + match xs + Cons(x,xx) -> Cons(f(x),xx.map(f)) + Nil -> Nil + +maps to: + + fun mapx( xs : list, f : a -> e b ) : e list + match xs + Cons(x,xx) -> Cons(f(x),xx.mapx(f)) + Nil -> Nil + + fun map( xs : list, f : a -> e b ) : e list + match xs + Nil -> Nil + _ -> xs.mapxx(f) +-----------------------------------------------------------------------------} + +module Core.Unroll( unrollDefs ) where + +import qualified Lib.Trace +import Control.Monad +import Control.Applicative +import Data.Maybe( catMaybes ) +import Lib.PPrint +import Common.Failure +import Common.NamePrim ( nameEffectOpen ) +import Common.Name +import Common.Range +import Common.Unique +import Common.Error +import Common.Syntax + +import Kind.Kind +import Type.Type +import Type.Kind +import Type.TypeVar +import Type.Pretty hiding (Env) +import qualified Type.Pretty as Pretty +import Type.Assumption +import Core.Core +import qualified Core.Core as Core +import Core.Pretty +import Core.CoreVar +import Core.Uniquefy + +trace s x = + Lib.Trace.trace s + x + + + +unrollDefs :: Pretty.Env -> Int -> CorePhase () +unrollDefs penv unrollMax + = liftCorePhaseUniq $ \uniq defs -> + runUnroll penv unrollMax uniq $ + do --traceDoc $ \penv -> text "Core.Unrolline.inlineDefs:" <+> ppUnrollines penv inlines + unrollDefGroups defs + + +{-------------------------------------------------------------------------- + transform definition groups +--------------------------------------------------------------------------} +unrollDefGroups :: DefGroups -> Unroll DefGroups +unrollDefGroups dgs + = do xss <- mapM unrollDefGroup dgs + return (concat xss) + +unrollDefGroup :: DefGroup -> Unroll DefGroups +unrollDefGroup (DefRec [def]) + = unrollRecDef def + +unrollDefGroup dg + = return [dg] + +unrollRecDef :: Def -> Unroll [DefGroup] +unrollRecDef def + = withCurrentDef def $ + do -- traceDoc $ \penv -> text "enter def" + dgs <- case defExpr def of + Lam pars eff body + -> unrollBody def [] pars eff body + TypeLam tpars (Lam pars eff body) + -> unrollBody def tpars pars eff body + _ -> return [] + return (if null dgs then [DefRec [def]] else dgs) + +unrollBody :: Def -> [TypeVar] -> [TName] -> Effect -> Expr -> Unroll [DefGroup] +unrollBody def tpars pars eff body + = case body of + Case exprs (branches@((Branch pats _):(_:_))) | all (\x -> costExpr x == 0) exprs -- todo: allow more (total) expressions? + -> case extractNonRecBranches (defTName def) [] branches of + (nonrecbs,recbs) | length nonrecbs > 0 && length recbs > 0 + -> do -- unrollTrace "do unroll" + let dname = defTName def + rname <- uniqueTNameFrom dname + let info = InfoArity (length tpars) (length pars) + sub = [(dname, Var rname info)] + rdef = def{ defName = getName rname, defExpr = (sub |~> defExpr def), defVis = Private } + + rcall = App (makeTypeApp (Var rname info) [TVar tv | tv <- tpars]) [Var v InfoNone | v <- pars] + wild = Branch (map (\_ -> PatWild) pats) [Guard exprTrue rcall] + mkFun b = (if null tpars then id else TypeLam tpars) (Lam pars eff b) + ddef = def{ defExpr = mkFun (Case exprs (nonrecbs ++ [wild])), defInline = InlineAlways, + defDoc = "// unrolling of singleton matches of " ++ show (getName rname) ++ "\n" } + verboseDoc $ \penv -> text ("unroll " ++ show (defName ddef) ++ " (to " ++ show (defName rdef) ++ ")") + return [DefRec [rdef], DefNonRec ddef] + _ -> do -- unrollTrace "no unroll" + return [] + -- todo: allow (small) let bindings? + _ -> return [] + + + +extractNonRecBranches :: TName -> [Branch] -> [Branch] -> ([Branch],[Branch]) +-- stop on end +extractNonRecBranches defname recs [] + = ([],recs) +-- stop also when we cannot push down patterns of recursive branches any further +extractNonRecBranches defname recs (b@(Branch pats guards) : bs) | any (matchCanOverlap b) recs + = ([],recs ++ [b] ++ bs) +-- otherwise +extractNonRecBranches defname recs (b@(Branch pats guards) : bs) + = if not (all singletonPat pats) || -- we only want cheap matches in the unrolling + tnamesMember defname (fv guards) -- and they should be non-recursive + then -- assume it contains a recursive call + -- push down as long the other patterns don't match to maximize non-recursive matches + extractNonRecBranches defname (recs ++ [b]) bs + else -- surely non-recursive, keep going + let (nonrecbs,recbs) = extractNonRecBranches defname recs bs + newb = if null recs then b else dontSkip b + in (newb:nonrecbs,recbs) + +-- is this a singleton (which can be matched without memory access) +singletonPat :: Pattern -> Bool +singletonPat pat + = case pat of + PatVar _ p -> singletonPat p + PatWild -> True + PatLit _ -> True + PatCon{patConPatterns=[]} -> True + _ -> False + +-- Patterns could overlap? (can be conservative, returning True is always ok) +matchCanOverlap (Branch pats1 _) (Branch pats2 _) + = any patCanOverlap (zip pats1 pats2) + where + patCanOverlap pp + = case pp of + (PatWild, _) -> True + (_, PatWild) -> True + (PatVar _ p1,p2) -> patCanOverlap (p1,p2) + (p1,PatVar _ p2) -> patCanOverlap (p1,p2) + (PatLit lit1,PatLit lit2) + -> lit1 == lit2 + (PatCon{patConName=name1}, PatCon{patConName=name2}) + -> name1 == name2 -- TODO: make more precise? + _ -> True + +dontSkip :: Branch -> Branch +dontSkip (Branch pats guards) + = Branch (map noskip pats) guards + where + noskip pat + = case pat of + PatVar name p -> PatVar name (noskip p) + PatCon{patConPatterns=ps} -> pat{ patConSkip = False, patConPatterns = map noskip ps } + _ -> pat + +{-------------------------------------------------------------------------- + Unroll monad +--------------------------------------------------------------------------} +newtype Unroll a = Unroll (Env -> State -> Result a) + +data Env = Env{ currentDef :: [Def], + prettyEnv :: Pretty.Env, + unrollMax :: Int } + +data State = State{ uniq :: !Int } + +data Result a = Ok a State + +runUnroll :: Pretty.Env -> Int -> Int -> Unroll a -> (a,Int) +runUnroll penv unrollMax u (Unroll c) + = case c (Env [] penv unrollMax) (State u) of + Ok x st -> (x,uniq st) + +instance Functor Unroll where + fmap f (Unroll c) = Unroll (\env st -> case c env st of + Ok x st' -> Ok (f x) st') + +instance Applicative Unroll where + pure x = Unroll (\env st -> Ok x st) + (<*>) = ap + +instance Monad Unroll where + -- return = pure + (Unroll c) >>= f = Unroll (\env st -> case c env st of + Ok x st' -> case f x of + Unroll d -> d env st' ) + +instance HasUnique Unroll where + updateUnique f = Unroll (\env st -> Ok (uniq st) st{ uniq = (f (uniq st)) }) + setUnique i = Unroll (\env st -> Ok () st{ uniq = i} ) + +withEnv :: (Env -> Env) -> Unroll a -> Unroll a +withEnv f (Unroll c) + = Unroll (\env st -> c (f env) st) + +--withUnique :: (Int -> (a,Int)) -> Unroll a +--withUnique f +-- = Unroll (\env st -> let (x,u') = f (uniq st) in Ok x (st{ uniq = u'})) + +getEnv :: Unroll Env +getEnv + = Unroll (\env st -> Ok env st) + +updateSt :: (State -> State) -> Unroll State +updateSt f + = Unroll (\env st -> Ok st (f st)) + +withCurrentDef :: Def -> Unroll a -> Unroll a +withCurrentDef def action + = -- trace ("inl def: " ++ show (defName def)) $ + withEnv (\env -> env{currentDef = def:currentDef env}) $ + do -- traceDoc $ (\penv -> text "\ndefinition:" <+> prettyDef penv{Pretty.coreShowDef=True} def) + action + + +traceDoc :: (Pretty.Env -> Doc) -> Unroll () +traceDoc f + = do env <- getEnv + unrollTrace (show (f (prettyEnv env))) + +unrollTrace :: String -> Unroll () +unrollTrace msg + = do env <- getEnv + trace ("inl: " ++ show (map defName (currentDef env)) ++ ": " ++ msg) $ return () + +uniqueTNameFrom :: TName -> Unroll TName +uniqueTNameFrom tname + = do i <- unique + let name = toHiddenUniqueName i "unroll" (getName tname) + return (TName name (typeOf tname)) + +verboseDoc :: (Pretty.Env -> Doc) -> Unroll () +verboseDoc f + = do env <- getEnv + when (verbose (prettyEnv env) >= 2) $ + Lib.Trace.trace (show (f (prettyEnv env))) (return ()) \ No newline at end of file diff --git a/src/Kind/Infer.hs b/src/Kind/Infer.hs index b2a15c056..0a59bbdd4 100644 --- a/src/Kind/Infer.hs +++ b/src/Kind/Infer.hs @@ -20,7 +20,7 @@ -} ----------------------------------------------------------------------------- -module Kind.Infer (inferKinds) where +module Kind.Infer (inferKinds ) where import Lib.Trace -- import Type.Pretty @@ -28,12 +28,13 @@ import Lib.Trace import Data.Char(isAlphaNum) import Data.List(groupBy,intersperse,nubBy,sortOn) import Data.Maybe(catMaybes) +import Control.Monad(when) import Lib.PPrint import Common.Failure import Common.Unique( uniqueId, setUnique, unique ) import Common.Error -import Common.ColorScheme( ColorScheme, colorType, colorSource ) +import Common.ColorScheme( ColorScheme, colorType, colorSource, colorCons ) import Common.Range import Common.Syntax( Platform(..) ) import Common.Name @@ -50,7 +51,7 @@ import Kind.Assumption import Kind.Constructors import Kind.Newtypes import Kind.Synonym - +import Kind.Repr( createDataDef ) import Type.Type import Type.Assumption import Type.TypeVar( tvsIsEmpty, ftv, subNew, (|->), tvsMember, tvsList ) @@ -190,7 +191,7 @@ synCopyCon modName info con params = [ValueBinder name Nothing (if not (hasAccessor name t con) then Nothing else (Just (app (var name) [var argName]))) rc rc| (name,t) <- conInfoParams con] expr = Lam ([ValueBinder argName Nothing Nothing rc rc] ++ params) body rc body = app (var (conInfoName con)) [var name | (name,tp) <- conInfoParams con] - def = DefNonRec (Def (ValueBinder nameCopy () (Ann expr fullTp rc) rc rc) rc (dataInfoVis info) (DefFun []) InlineAuto "") + def = DefNonRec (Def (ValueBinder nameCopy () (Ann expr fullTp rc) rc rc) rc (dataInfoVis info) (defFun []) InlineAuto "") in def hasAccessor :: Name -> Type -> ConInfo -> Bool @@ -250,7 +251,7 @@ synAccessors modName info messages = [Lit (LitString (sourceName (posSource (rangeStart rng)) ++ show rng) rng), Lit (LitString (show name) rng)] doc = "// Automatically generated. Retrieves the `" ++ show name ++ "` constructor field of the `:" ++ nameId (dataInfoName info) ++ "` type.\n" - in DefNonRec (Def (ValueBinder name () expr rng rng) rng visibility (DefFun [Borrow]) InlineAlways doc) + in DefNonRec (Def (ValueBinder name () expr rng rng) rng visibility (defFunEx [Borrow] noFip) InlineAlways doc) in map synAccessor fields @@ -268,7 +269,7 @@ synTester info con branch2 = Branch (PatWild rc) [Guard guardTrue (Var nameFalse False rc)] patterns = [(Nothing,PatWild rc) | _ <- conInfoParams con] doc = "// Automatically generated. Tests for the `" ++ nameId (conInfoName con) ++ "` constructor of the `:" ++ nameId (dataInfoName info) ++ "` type.\n" - in [DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) (DefFun [Borrow]) InlineAlways doc)] + in [DefNonRec (Def (ValueBinder name () expr rc rc) rc (conInfoVis con) (defFunEx [Borrow] (Fip (AllocAtMost 0))) InlineAlways doc)] synConstrTag :: (ConInfo) -> DefGroup Type synConstrTag (con) @@ -397,7 +398,7 @@ infExternals externals return (ext:exts) infExternal :: [Name] -> External -> KInfer (Core.External,[Name]) -infExternal names (External name tp pinfos nameRng rng calls vis doc) +infExternal names (External name tp pinfos nameRng rng calls vis fip doc) = do tp' <- infResolveType tp (Check "Externals must be values" rng) qname <- qualifyDef name let cname = let n = length (filter (==qname) names) in @@ -408,7 +409,7 @@ infExternal names (External name tp pinfos nameRng rng calls vis doc) addRangeInfo rng (Decl "external" qname (mangle cname tp')) -- trace ("infExternal: " ++ show cname ++ ": " ++ show (pretty tp')) $ return (Core.External cname tp' pinfos (map (formatCall tp') calls) - vis nameRng doc, qname:names) + vis fip nameRng doc, qname:names) infExternal names (ExternalImport imports range) = return (Core.ExternalImport imports range, names) @@ -805,176 +806,67 @@ resolveTypeDef isRec recNames (DataType newtp params constructors range vis sort then mapM (\karg -> do{ id <- uniqueId "k"; return (TypeVar id karg Bound) }) kargs -- invent parameters if they are not given (and it has an arrow kind) else mapM (\param -> freshTypeVar param Bound) params' let tvarMap = M.fromList (zip (map getName params') typeVars) - consinfos <- mapM (resolveConstructor (getName newtp') sort (not (dataDefIsOpen ddef) && length constructors == 1) typeResult typeVars tvarMap) constructors - let (constructors',infos) = unzip consinfos + cs <- getColorScheme let qname = getName newtp' fname = unqualify qname name = if (isHandlerName fname) then fromHandlerName fname else fname nameDoc = color (colorType cs) (pretty name) + + consinfos <- mapM (resolveConstructor (getName newtp') sort + (not (dataDefIsOpen ddef) && length constructors == 1) + typeResult typeVars tvarMap) constructors + let (constructors',conInfos0) = unzip consinfos + --check recursion if (sort == Retractive) then return () else let effNames = concatMap fromOpsName recNames fromOpsName nm = if (isOperationsName nm) then [fromOperationsName nm] else [] - in if (any (occursNegativeCon (recNames ++ effNames)) (infos)) + in if (any (occursNegativeCon (recNames ++ effNames)) (conInfos0)) then do addError range (text "Type" <+> nameDoc <+> text "is declared as being" <-> text " (co)inductive but it occurs recursively in a negative position." <-> text " hint: declare it as a 'type rec' (or 'effect rec)' to allow negative occurrences") else return () - {- - -- is a maybe like reference type? - let isAsMaybe = not isRec && case sortOn (length . conInfoParams) infos of - [nothing,just] -> length (conInfoParams nothing) == 0 && case conInfoParams just of - [(_,TVar _)] -> True - _ -> False - _ -> False - -} - -- value types - ddef' <- case ddef of - DataDefNormal - -> return (if (isRec) then DataDefRec else DataDefNormal) - DataDefValue _ _ | isRec - -> do addError range (text "Type" <+> nameDoc <+> text "cannot be declared as a value type since it is recursive.") - return ddef - DataDefAuto | isRec - -> return DataDefRec - -- DataDefAuto | isAsMaybe - -- -> return DataDefNormal - DataDefOpen - -> return DataDefOpen - DataDefRec - -> return DataDefRec - _ -- Value or auto, and not recursive - -> -- determine the raw fields and total size - do platform <- getPlatform - dd <- toDefValues platform (ddef/=DataDefAuto) qname nameDoc infos - case (ddef,dd) of -- note: m = raw, n = scan - (DataDefValue _ _, DataDefValue m n) - -> if (hasKindStarResult (getKind typeResult)) - then return (DataDefValue m n) - else do addError range (text "Type" <+> nameDoc <+> text "is declared as a value type but does not have a value kind ('V').") -- should never happen? - return DataDefNormal - (DataDefValue _ _, DataDefNormal) - -> do addError range (text "Type" <+> nameDoc <+> text "cannot be used as a value type.") -- should never happen? - return DataDefNormal - (DataDefAuto, DataDefValue m n) - -> if ((m + (n*sizePtr platform)) <= 3*(sizePtr platform) - && hasKindStarResult (getKind typeResult) - && (sort /= Retractive)) - then -- trace ("default to value: " ++ show name ++ ": " ++ show (m,n)) $ - return (DataDefValue m n) - else -- trace ("default to reference: " ++ show name ++ ": " ++ show (m,n)) $ - return (DataDefNormal) - _ -> return DataDefNormal + -- create datadef and conInfos with correct ValueRepr and ordered fields + let emitError d = addError range (text "Type" <+> nameDoc <+> d) + emitWarning d = addWarning range (text "Type" <+> nameDoc <+> d) + resultHasKindStar = hasKindStarResult (getKind typeResult) + maxMembers = maximum ([0] ++ map (length . conInfoParams) conInfos0) + conCount = length conInfos0 + willNeedStructTag = dataDefIsValue ddef && conCount > 1 && maxMembers >= 1 + extraFields = if (dataDefIsOpen ddef) then 1 {- open datatype tag -} + else if willNeedStructTag then 1 {- explicit struct tag -} + else 0 + platform <- getPlatform + (ddef1,conInfos1) + <- createDataDef emitError emitWarning lookupDataInfo + platform qname resultHasKindStar isRec sort extraFields ddef conInfos0 + + let dataInfo = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars conInfos1 range ddef1 vis doc + + assertion ("Kind.Infer.resolveTypeDef: assuming value struct tag but not inferred as such " ++ show (ddef,ddef1)) + ((willNeedStructTag && Core.needsTagField (fst (Core.getDataRepr dataInfo))) || not willNeedStructTag) $ return () + + + {- + -- adjust datainfo in case an extra value tag was needed + dataInfo <- case ddef1 of + DataDefValue (ValueRepr m n a) | Core.needsTagField (fst (Core.getDataRepr dataInfo0)) + -> -- recalculate with extra required tag field to the size + do (ddef2,conInfos2) <- createDataDef emitError emitWarning lookupDataInfo + platform qname resultHasKindStar isRec sort + 1 {- extra field for tag -} ddef1 {- guarantees value type again -} conInfos1 + let dataInfo1 = dataInfo0{ dataInfoDef = ddef2, dataInfoConstrs = conInfos2 } + return dataInfo1 + _ -> return dataInfo0 + -} -- trace (showTypeBinder newtp') $ addRangeInfo range (Decl (show sort) (getName newtp') (mangleTypeName (getName newtp'))) - let dataInfo = DataInfo sort (getName newtp') (typeBinderKind newtp') typeVars infos range ddef' vis doc return (Core.Data dataInfo isExtend) where conVis (UserCon name exist params result rngName rng vis _) = vis - toDefValues :: Platform -> Bool -> Name -> Doc -> [ConInfo] -> KInfer DataDef - toDefValues platform isVal qname nameDoc conInfos - = do ddefs <- mapM (toDefValue nameDoc) conInfos - ddef <- maxDataDefs platform qname isVal nameDoc ddefs - case ddef of - DataDefValue 0 0 -- enumeration - -> let n = length conInfos - in if (n < 256) then return $ DataDefValue 1 0 -- uint8_t - else if (n < 65536) then return $ DataDefValue 2 0 -- uint16_t - else return $ DataDefValue 4 0 -- uint32_t - _ -> return ddef - - toDefValue :: Doc -> ConInfo -> KInfer (Int,Int) - toDefValue nameDoc con - = do ddefs <- mapM (typeDataDef lookupDataInfo . snd) (conInfoParams con) - dd <- sumDataDefs nameDoc ddefs - -- trace ("datadefs: " ++ show nameDoc ++ "." ++ show (conInfoName con) ++ ": " ++ show ddefs ++ " to " ++ show dd) $ - return dd - - -- note: (m = raw, n = scan) - maxDataDefs :: Platform -> Name -> Bool -> Doc -> [(Int,Int)] -> KInfer DataDef - maxDataDefs platform name False nameDoc [] = return DataDefNormal - maxDataDefs platform name True nameDoc [] -- primitive abstract value type with no constructors - = do let size = if (name == nameTpChar || name == nameTpInt32 || name == nameTpFloat32) - then 4 - else if (name == nameTpFloat || name == nameTpInt64) - then 8 - else if (name == nameTpInt8) - then 1 - else if (name == nameTpInt16 || name == nameTpFloat16) - then 2 - else if (name == nameTpAny || name == nameTpCField || name == nameTpIntPtrT) - then (sizePtr platform) - else if (name==nameTpSSizeT) - then (sizeSize platform) - else 0 - m <- if (size <= 0) - then do addWarning range (text "Type:" <+> nameDoc <+> text "is declared as a primitive value type but has no known compilation size, assuming size" <+> pretty (sizePtr platform)) - return (sizePtr platform) - else return size - return (DataDefValue m 0) - maxDataDefs platform name isVal nameDoc [(m,n)] = return (DataDefValue m n) - maxDataDefs platform name isVal nameDoc (dd:dds) - = do dd2 <- maxDataDefs platform name isVal nameDoc dds - case (dd,dd2) of - ((0,0), DataDefValue m n) -> return (DataDefValue m n) - ((m,n), DataDefValue 0 0) -> return (DataDefValue m n) - ((m1,0), DataDefValue m2 0) -> return (DataDefValue (max m1 m2) 0) - ((0,n1), DataDefValue 0 n2) -> return (DataDefValue 0 (max n1 n2)) - ((m1,n1), DataDefValue m2 n2) - -- TODO: mixed raw is ok? - -- | m1 == m2 -> return (DataDefValue m1 (max n1 n2)) - | n1 == n2 -> return (DataDefValue (max m1 m2) n1) - | otherwise -> - do if (isVal) - then -- addError range (text "Type:" <+> nameDoc <+> text "is declared as a value type but has multiple constructors which varying raw types and regular types." <-> - -- text "hint: value types with multiple constructors must all use the same number of regular types when mixed with raw types (use 'box' to use a raw type as a regular type).") - addError range (text "Type:" <+> nameDoc <+> text "is declared as a value type but has multiple constructors with a different number of regular types." <-> - text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") - else return () - trace ("cannot default to a value type due to mixed raw/regular fields: " ++ show nameDoc) $ - return DataDefNormal -- (DataDefValue (max m1 m2) (max n1 n2)) - _ -> return DataDefNormal - - sumDataDefs :: Doc -> [DataDef] -> KInfer (Int,Int) - sumDataDefs nameDoc ddefs - = walk 0 0 ddefs - where - walk m n [] = return (m,n) - walk m n (dd:dds) - = do case dd of - DataDefValue m1 n1 - -> do if (m1 > 0 && n1 > 0) -- mixed raw and scan fields? - then mapM_ (checkNoClash nameDoc m1 n1) dds - else return () - walk (alignedAdd m m1) (n + n1) dds - _ -> walk m (n + 1) dds - - checkNoClash :: Doc -> Int -> Int -> DataDef -> KInfer () - checkNoClash nameDoc m1 n1 dd - = case dd of - DataDefValue m2 n2 | m2 > 0 && n2 > 0 - -> do addError range (text "Type:" <+> nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> - text ("hint: use 'box' on either field to make it a non-value type.")) - _ -> return () - - - -- get the DataDef for a previous type - typeDataDef :: Monad m => (Name -> m (Maybe DataInfo)) -> Type -> m DataDef - typeDataDef lookupDataInfo tp - = case expandSyn tp of - TCon (TypeCon name _) - -> do mbdi <- lookupDataInfo name - case mbdi of - Nothing -> failure ("Kind.Infer.resolve data def: unknown type: " ++ show name); - Just di -> return (dataInfoDef di) - TApp t _ -> typeDataDef lookupDataInfo t - TForall _ _ t -> typeDataDef lookupDataInfo t - _ -> return DataDefNormal - - occursNegativeCon :: [Name] -> ConInfo -> Bool occursNegativeCon names conInfo = let (_,_,rho) = splitPredType (conInfoType conInfo) @@ -1042,16 +934,28 @@ resolveConstructor typeName typeSort isSingleton typeResult typeParams idmap (Us if (null params') then result' else typeFun [(binderName p, binderType p) | (_,p) <- params'] typeTotal result' addRangeInfo rng (Decl "con" qname (mangleConName qname)) addRangeInfo rngName (Id qname (NICon scheme) True) + let fields = map (\(i,b) -> (if (nameIsNil (binderName b)) then newFieldName i else binderName b, binderType b)) (zip [1..] (map snd params')) + -- emitError makeMsg = do cs <- getColorScheme + -- let nameDoc = color (colorCons cs) (pretty name) + -- addError rng (makeMsg nameDoc) + platform <- getPlatform + -- (orderedFields,vrepr) <- orderConFields emitError lookupDataInfo platform (if isOpen then 1 else 0) fields return (UserCon qname exist' params' (Just result') rngName rng vis doc ,ConInfo qname typeName typeParams existVars - (map (\(i,b) -> (if (nameIsNil (binderName b)) then newFieldName i else binderName b, binderType b)) (zip [1..] (map snd params'))) + fields scheme typeSort rngName (map (binderNameRange . snd) params') (map fst params') isSingleton - vis - doc) + -- orderedFields vrepr + [] valueReprZero -- initialized later at the datadef + vis doc) + + +--------------------------------------------------------- +-- +--------------------------------------------------------- resolveConParam :: M.NameMap TypeVar -> (Visibility,ValueBinder (KUserType InfKind) (Maybe (Expr UserType))) -> KInfer (Visibility,ValueBinder Type (Maybe (Expr Type))) resolveConParam idmap (vis,vb) diff --git a/src/Kind/InferMonad.hs b/src/Kind/InferMonad.hs index 589cec485..b584ab5ae 100644 --- a/src/Kind/InferMonad.hs +++ b/src/Kind/InferMonad.hs @@ -77,11 +77,11 @@ instance Functor KInfer where = KInfer (\env -> \st -> let r = ki env st in r{ result = f (result r) }) instance Applicative KInfer where - pure = return - (<*>) = ap + pure x = KInfer (\env -> \st -> KResult x [] [] st) + (<*>) = ap instance Monad KInfer where - return x = KInfer (\env -> \st -> KResult x [] [] st) + -- return = pure (KInfer ki) >>= f = KInfer (\env -> \st -> case ki env st of @@ -250,7 +250,9 @@ infQualifiedName name range Right (name',alias) -> if (not (nameCaseEqual (qualifier name) alias)) then do let cs = cscheme env - addError range (text "module" <+> ppModule cs name <+> text "should be cased as" <+> color (colorModule cs) (pretty alias)) + addError range (text "module" <+> ppModule cs name <+> text "should be cased as" <+> color (colorModule cs) (pretty alias) + -- <+> text (showPlain name ++ ", " ++ showPlain alias) + ) return name' else return name' Left [] @@ -290,10 +292,11 @@ findInfKind name0 range addError range (text "type" <+> (ppType cs (unqualify name0)) <+> text "should be cased as" <+> ppType cs (unqualify name')) else return () case mbAlias of - Just alias | nameModule name0 /= show alias + Just alias | nameModule name0 /= showPlain alias -> do let cs = cscheme env addError range (text "module" <+> color (colorModule cs) (text (nameModule name0)) <+> text "should be cased as" <+> color (colorModule cs) (pretty alias) -- <+> text (show (name,qname,mbAlias,name0)) + -- <+> text ( nameModule name0 ++ ", " ++ showPlain alias) ) _ -> return () return (qname,KICon kind) diff --git a/src/Kind/Repr.hs b/src/Kind/Repr.hs new file mode 100644 index 000000000..298c0dfdc --- /dev/null +++ b/src/Kind/Repr.hs @@ -0,0 +1,263 @@ +------------------------------------------------------------------------------ +-- Copyright 2012-2023, Microsoft Research, Daan Leijen. +-- +-- This is free software; you can redistribute it and/or modify it under the +-- terms of the Apache License, Version 2.0. A copy of the License can be +-- found in the LICENSE file at the root of this distribution. +----------------------------------------------------------------------------- +{- + +-} +----------------------------------------------------------------------------- +module Kind.Repr( orderConFields, createDataDef ) where + +import Control.Monad( when ) +import Lib.PPrint +import Common.Name +import Common.NamePrim +import Common.Syntax +import Common.Failure +import Type.Type + +--------------------------------------------------------- +-- Create a datadef and elaborate conInfo's with a ValueRepr +-- and correctly ordered fields depending on alignment +-- constraints and platform sizes. +--------------------------------------------------------- + +-- value types +createDataDef :: Monad m => (Doc-> m ()) -> (Doc-> m ()) -> (Name -> m (Maybe DataInfo)) + -> Platform -> Name -> Bool -> Bool -> DataKind + -> Int -> DataDef -> [ConInfo] -> m (DataDef,[ConInfo]) +createDataDef emitError emitWarning lookupDataInfo + platform name resultHasKindStar isRec sort + extraFields defaultDef conInfos0 + = do --calculate the value repr of each constructor + conInfos <- mapM createConInfoRepr conInfos0 + + -- datadef + let maxMembers = maximum ([0] ++ map (length . conInfoParams) conInfos) + conCount = length conInfos + canbeValue = resultHasKindStar && sort /= Retractive + isEnum = canbeValue && maxMembers == 0 && conCount >= 1 + isIso = canbeValue && maxMembers == 1 && conCount == 1 + + ddef <- case defaultDef of + DataDefOpen + -> return DataDefOpen + DataDefRec + -> return DataDefRec + + DataDefNormal | isRec + -> return DataDefRec + DataDefNormal + -> do dd <- createMaxDataDef conInfos + case dd of + {- DataDefValue vr | isEnum -- allow allocated enum types + -> return dd -} + {- DataDefValue vr | isIso -- iso types are always value types + -> return dd -} + _ -> return DataDefNormal + + DataDefAuto | isRec + -> return DataDefRec + DataDefAuto + -> do dd <- createMaxDataDef conInfos + case dd of + DataDefValue vr | isEnum + -> return dd + DataDefValue vr | isIso -- iso types are preferred as value types + -> return dd + DataDefValue vr + -> do let wouldGetTagField = (conCount > 1 && not isEnum) + size = valueReprSize platform vr + (if wouldGetTagField then sizeField platform else 0) + when ((size <= 2*sizePtr platform) && (maxMembers <= 3) && canbeValue) $ + emitWarning $ text "may be better declared as a value type for efficiency (e.g. 'value type/struct')," <-> + text "or declared as a reference type to suppress this warning (e.g. 'ref type/struct')" + return DataDefNormal + _ -> return DataDefNormal + + DataDefValue{} | isRec + -> do emitError $ text "cannot be declared as a value type since it is recursive." + return DataDefNormal + DataDefValue{} | not resultHasKindStar + -> do emitError $ text "is declared as a value type but does not have a value kind ('V')." -- should never happen? + return DataDefNormal + DataDefValue{} | sort == Retractive + -> do emitError $ text "is declared as a value type but is not (co)inductive." + return DataDefNormal + DataDefValue{} + -> do dd <- createMaxDataDef conInfos + case dd of + DataDefValue vr + -> do let size = valueReprSize platform vr + when (size > 4*sizePtr platform) $ + emitWarning (text "requires" <+> pretty size <+> text "bytes which is rather large for a value type") + when isEnum $ + emitWarning (text "is an enumeration -- there is no need to declare it as a value type") + -- when isIso $ + -- emitWarning (text "is a isomorphic type -- there is no need to declare it as a value type") + return dd + _ -> do emitError $ text "cannot be used as a value type." -- should never happen? + return DataDefNormal + return (ddef,conInfos) + where + isVal :: Bool + isVal = dataDefIsValue defaultDef + + -- createConInfoRepr :: ConInfo -> m ConInfo + createConInfoRepr conInfo + = do (orderedFields,vrepr) <- orderConFields emitError (text "constructor" <+> pretty (conInfoName conInfo)) + lookupDataInfo platform extraFields (conInfoParams conInfo) + return (conInfo{ conInfoOrderedParams = orderedFields, conInfoValueRepr = vrepr } ) + + -- createMaxDataDef :: [ConInfo] -> m DataDef + createMaxDataDef conInfos + = do let vreprs = map conInfoValueRepr conInfos + ddef <- maxDataDefs vreprs + case ddef of + DataDefValue (ValueRepr 0 0 0) -- enumeration + -> let n = length conInfos + in if (n < 256) then return $ DataDefValue (valueReprRaw 1) -- uint8_t + else if (n < 65536) then return $ DataDefValue (valueReprRaw 2) -- uint16_t + else return $ DataDefValue (valueReprRaw 4) -- uint32_t + _ -> return ddef + + + -- note: (m = raw, n = scan) + -- maxDataDefs :: Monad m => [ValueRepr] -> m DataDef + maxDataDefs [] + = if not isVal + then return DataDefNormal -- reference type, no constructors + else do let size = if (name == nameTpChar || name == nameTpInt32 || name == nameTpFloat32) + then 4 + else if (name == nameTpFloat || name == nameTpInt64) + then 8 + else if (name == nameTpInt8) + then 1 + else if (name == nameTpInt16 || name == nameTpFloat16) + then 2 + else if (name == nameTpAny || name == nameTpFieldAddr || name == nameTpIntPtrT) + then (sizePtr platform) + else if (name==nameTpSSizeT) + then (sizeSize platform) + else 0 + m <- if (size <= 0) + then do emitWarning $ text "is declared as a primitive value type but has no known compilation size, assuming size" <+> pretty (sizePtr platform) + return (sizePtr platform) + else return size + return (DataDefValue (valueReprNew m 0 m)) + maxDataDefs [vr] -- singleton value + = return (DataDefValue vr) + maxDataDefs (vr:vrs) + = do dd <- maxDataDefs vrs + case (vr,dd) of + (ValueRepr 0 0 _, DataDefValue v) -> return (DataDefValue v) + (v, DataDefValue (ValueRepr 0 0 _)) -> return (DataDefValue v) + (ValueRepr m1 0 a1, DataDefValue (ValueRepr m2 0 a2)) + -> return (DataDefValue (valueReprNew (max m1 m2) 0 (max a1 a2))) + (ValueRepr 0 n1 a1, DataDefValue (ValueRepr 0 n2 a2)) + -> return (DataDefValue (valueReprNew 0 (max n1 n2) (max a1 a2))) + (ValueRepr m1 n1 a1, DataDefValue (ValueRepr m2 n2 a2)) + -- equal scan fields + | n1 == n2 -> return (DataDefValue (valueReprNew (max m1 m2) n1 (max a1 a2))) + -- non-equal scan fields + | otherwise -> + do when isVal $ + emitError (text "is declared as a value type but has" <+> text "multiple constructors with a different number of regular types overlapping with value types." <-> + text "hint: value types with multiple constructors must all use the same number of regular types (use 'box' to use a value type as a regular type).") + -- else emitWarning (text "cannot be defaulted to a value type as it has" <+> text "multiple constructors with a different number of regular types overlapping with value types.") + -- trace ("warning: cannot default to a value type due to mixed raw/regular fields: " ++ show nameDoc) $ + return DataDefNormal -- (DataDefValue (max m1 m2) (max n1 n2)) + _ -> return DataDefNormal + + +--------------------------------------------------------- +-- Determine the size of a constructor +--------------------------------------------------------- + +-- order constructor fields of constructors with raw field so the regular fields come first to be scanned. +-- return the ordered fields, and a ValueRepr (raw size part, the scan count (including tags), align, and full size) +-- The size is used for reuse and should include all needed fields including the tag field for "open" datatypes +orderConFields :: Monad m => (Doc -> m ()) -> Doc -> (Name -> m (Maybe DataInfo)) -> Platform + -> Int -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) +orderConFields emitError nameDoc getDataInfo platform extraPreScan fields + = do visit ([], [], [], extraPreScan, 0) fields + where + -- visit :: ([((Name,Type),ValueRepr)],[((Name,Type),ValueRepr)],[(Name,Type)],Int,Int) -> [(Name,Type)] -> m ([(Name,Type)],ValueRepr) + visit (rraw, rmixed, rscan, scanCount0, alignment0) [] + = do when (length rmixed > 1) $ + do emitError (nameDoc <+> text "has multiple value type fields that each contain both raw types and regular types." <-> + text ("hint: use 'box' on either field to make it a non-value type.")) + let -- scancount and size before any mixed and raw fields + preSize = (sizeHeader platform) + (scanCount0 * sizeField platform) + + -- if there is a mixed value member (with scan fields) we may need to add padding scan fields (!) + -- (or otherwise the C compiler may insert uninitialized padding) + (padding,mixedScan) + = case rmixed of + ((_,ValueRepr _ scan ralign):_) + -> let padSize = preSize `mod` ralign + padCount = padSize `div` sizeField platform + in assertion ("Kind.Infer.orderConFields: illegal alignment: " ++ show ralign) (padSize `mod` sizeField platform == 0) $ + ([((newPaddingName (scanCount0 + i),typeAny),valueReprScan 1) | i <- [1..padCount]] + ,scan + padCount) + [] -> ([],0) + + -- calculate the rest now + scanCount = scanCount0 + mixedScan + alignment = if scanCount > 0 then max alignment0 (sizeField platform) else alignment0 + rest = padding ++ rmixed ++ reverse rraw + restSizes = [valueReprSize platform vr | (_field,vr) <- rest] + restFields= [field | (field,_vr) <- rest] + size = alignedSum preSize restSizes + rawSize = size - (sizeHeader platform) - (scanCount * sizeField platform) + vrepr = valueReprNew rawSize scanCount alignment + -- (if null padding then id else trace ("constructor: " ++ show cname ++ ": " ++ show vrepr) $ + return (reverse rscan ++ restFields, vrepr) + + visit (rraw,rmixed,rscan,scanCount,alignment0) (field@(name,tp) : fs) + = do mDataDef <- getDataDef getDataInfo tp + case mDataDef of + Just (DataDefValue vr@(ValueRepr raw scan align)) + -> -- let extra = if (hasTagField dataRepr) then 1 else 0 in -- adjust scan count for added "tag_t" members in structs with multiple constructors + let alignment = max align alignment0 in + if (raw > 0 && scan > 0) + then -- mixed raw/scan: put it at the head of the raw fields (there should be only one of these as checked in Kind/Infer) + -- but we count them to be sure (and for function data) + visit (rraw, (field,vr):rmixed, rscan, scanCount, alignment) fs + else if (raw > 0) + then visit (insertRaw field vr rraw, rmixed, rscan, scanCount, alignment) fs + else visit (rraw, rmixed, field:rscan, scanCount + scan, alignment) fs + _ -> visit (rraw, rmixed, field:rscan, scanCount + 1, alignment0) fs + + -- insert raw fields in (reversed) order of alignment so they align to the smallest total size in a datatype + insertRaw :: (Name,Type) -> ValueRepr -> [((Name,Type),ValueRepr)] -> [((Name,Type),ValueRepr)] + insertRaw field vr ((f,vrf):rs) + | valueReprAlignment vr <= valueReprAlignment vrf = (field,vr):(f,vrf):rs + | otherwise = (f,vrf):insertRaw field vr rs + insertRaw field vr [] + = [(field,vr)] + + + +-- | Return the DataDef for a type. +-- This may be 'Nothing' for abstract types. +getDataDef :: Monad m => (Name -> m (Maybe DataInfo)) -> Type -> m (Maybe DataDef) +getDataDef lookupDI tp + = case extractDataDefType tp of + Nothing -> return $ Just DataDefNormal + Just name | name == nameTpBox -> return $ Just DataDefNormal + Just name -> do mdi <- lookupDI name + case mdi of + Nothing -> return Nothing + Just di -> return $ Just (dataInfoDef di) + where + extractDataDefType :: Type -> Maybe Name + extractDataDefType tp + = case expandSyn tp of + TApp t _ -> extractDataDefType t + TForall _ _ t -> extractDataDefType t + TCon tc -> Just (typeConName tc) + _ -> Nothing + diff --git a/src/Static/BindingGroups.hs b/src/Static/BindingGroups.hs index e6fc31765..4e2652ddf 100644 --- a/src/Static/BindingGroups.hs +++ b/src/Static/BindingGroups.hs @@ -113,10 +113,10 @@ dependencies modName defs (depDefs, deps) = unzipWith (id,unions) (map (dependencyDef modName) defs) dependencyDef :: Name -> UserDef -> (UserDef, Deps) -dependencyDef modName (Def binding range vis isVal inline defDoc) - = (Def depBinding range vis isVal inline defDoc, deps) +dependencyDef modName def + = (def{ defBinder = depBinding}, deps) where - (depBinding,deps) = dependencyBinding modName binding + (depBinding,deps) = dependencyBinding modName (defBinder def) dependencyBinding :: Name -> UserValueBinder UserExpr -> (UserValueBinder UserExpr, Deps) dependencyBinding modName vb diff --git a/src/Static/FixityResolve.hs b/src/Static/FixityResolve.hs index 5ed163535..04ca9c65f 100644 --- a/src/Static/FixityResolve.hs +++ b/src/Static/FixityResolve.hs @@ -58,9 +58,9 @@ resolveDefGroup (DefRec defs) resolveDefGroup (DefNonRec def) = resolveDef def >>= return . DefNonRec -resolveDef (Def binder range vis isVal inline doc) - = do binder' <- resolveBinder binder - return (Def binder' range vis isVal inline doc) +resolveDef def + = do binder' <- resolveBinder (defBinder def) + return def{ defBinder = binder'} resolveBinder binder = do expr' <- resolveExpr (binderExpr binder) @@ -173,11 +173,11 @@ instance Functor FixM where fmap = liftM instance Applicative FixM where - pure = return - (<*>) = ap + pure x = FixM (\fixmap -> Res x []) + (<*>) = ap instance Monad FixM where - return x = FixM (\fixmap -> Res x []) + -- return = pure (FixM fm) >>= f = FixM (\fixmap -> case fm fixmap of Res x errs1 -> case f x of FixM fm' -> case fm' fixmap of diff --git a/src/Syntax/Lexer.x b/src/Syntax/Lexer.x index eaa469c1d..380d1ce59 100644 --- a/src/Syntax/Lexer.x +++ b/src/Syntax/Lexer.x @@ -56,7 +56,7 @@ $charesc = [nrt\\\'\"] -- " ----------------------------------------------------------- @newline = $return?$linefeed -@utf8 = [\xC2-\xDF] $cont +@utf8valid = [\xC2-\xDF] $cont | \xE0 [\xA0-\xBF] $cont | [\xE1-\xEC] $cont $cont | \xED [\x80-\x9F] $cont @@ -65,6 +65,11 @@ $charesc = [nrt\\\'\"] -- " | [\xF1-\xF3] $cont $cont $cont | \xF4 [\x80-\x8F] $cont $cont +@utf8unsafe = \xE2 \x80 [\x8E-\x8F\xAA-\xAE] + | \xE2 \x81 [\xA6-\xA9] + +@utf8 = @utf8valid + @linechar = [$graphic$space$tab]|@utf8 @commentchar = ([$graphic$space$tab] # [\/\*])|@newline|@utf8 @@ -166,14 +171,16 @@ program :- -------------------------- -- string literals - @stringchar+ { more id } + @utf8unsafe { string $ unsafeChar "string" } + @stringchar { more id } \\$charesc { more fromCharEscB } \\@hexesc { more fromHexEscB } \" { pop $ \_ -> withmore (string LexString . B.init) } -- " @newline { pop $ \_ -> constant (LexError "string literal ended by a new line") } . { string $ \s -> LexError ("illegal character in string: " ++ show s) } - @stringraw+ { more id } + @utf8unsafe { string $ unsafeChar "raw string" } + @stringraw { more id } \"\#* { withRawDelim $ \s delim -> if (s == delim) then -- done @@ -194,21 +201,24 @@ program :- "*/" { pop $ \state -> if state==comment then more id else withmore (string $ LexComment . filter (/='\r')) } "/*" { push $ more id } - @commentchar+ { more id } + @utf8unsafe { string $ unsafeChar "comment" } + @commentchar { more id } [\/\*] { more id } . { string $ \s -> LexError ("illegal character in comment: " ++ show s) } -------------------------- -- line comments - @linechar+ { more id } + @utf8unsafe { string $ unsafeChar "line comment" } + @linechar { more id } @newline { pop $ \_ -> withmore (string $ LexComment . filter (/='\r')) } . { string $ \s -> LexError ("illegal character in line comment: " ++ show s) } -------------------------- -- line directives (ignored for now) - @linechar+ { more id } + @utf8unsafe { string $ unsafeChar "line directive" } + @linechar { more id } @newline { pop $ \_ -> withmore (string $ LexComment . filter (/='\r')) } . { string $ \s -> LexError ("illegal character in line directive: " ++ show s) } @@ -255,6 +265,10 @@ startsWith s [] = True startsWith [] _ = False startsWith (c:cs) (p:ps) = if (p==c) then startsWith cs ps else False +unsafeChar :: String -> String -> Lex +unsafeChar kind s + = LexError ("unsafe character in " ++ kind ++ ": \\u" ++ showHex 4 (fromEnum (head s))) + ----------------------------------------------------------- -- Reserved ----------------------------------------------------------- @@ -277,6 +291,7 @@ reservedNames , "ctl", "final", "raw" , "if", "then", "else", "elif" , "return", "match", "with", "in" + , "ctx", "hole" , "forall", "exists", "some" , "pub", "abstract" , "module", "import", "as" diff --git a/src/Syntax/Parse.hs b/src/Syntax/Parse.hs index d37a84ba4..e2fb7b663 100644 --- a/src/Syntax/Parse.hs +++ b/src/Syntax/Parse.hs @@ -18,7 +18,7 @@ module Syntax.Parse( parseProgramFromFile -- used by the core parser , lexParse, parseLex, LexParser, parseLexemes, parseInline - , visibility, modulepath, importAlias + , visibility, modulepath, importAlias, parseFip , tbinderId, constructorId, funid, paramid , braced, semiBraces, semis, semiColons1, semiBraced , angles, anglesCommas, parensCommas, parens, curlies @@ -38,7 +38,7 @@ import Data.Either (partitionEithers) import Lib.PPrint hiding (string,parens,integer,semiBraces,lparen,comma,angles,rparen,rangle,langle) import qualified Lib.PPrint as PP (string) -import Control.Monad (mzero) +import Control.Monad (mzero,when) import Data.Monoid (Endo(..)) import Text.Parsec hiding (space,tab,lower,upper,alphaNum,sourceName,optional) import Text.Parsec.Error @@ -170,7 +170,7 @@ expression name = interactive $ do e <- aexpr let r = getRange e - return (Def (ValueBinder name () (Lam [] e r) r r) r Public (DefFun []) InlineNever "" + return (Def (ValueBinder name () (Lam [] e r) r r) r Public (DefFun [] noFip) InlineNever "" -- ,Def (ValueBinder (prepend ".eval" name) () (Lam [] (App (Var nameGPrint False r) [Var name False r] r))) ) @@ -323,12 +323,13 @@ externDecl dvis <|> try ( do (vis,vrng) <- visibility dvis inline <- parseInline + fip <- parseFip (krng,doc) <- dockeyword "extern" - return (Right (combineRange vrng krng, vis, doc, inline))) + return (Right (combineRange vrng krng, vis, doc, inline, fip))) case lr of Left p -> do extern <- p return [DefExtern extern] - Right (krng,vis,doc,inline) + Right (krng,vis,doc,inline,fip) -> do (name,nameRng) <- funid (pars,pinfos,args,tp,annotate) <- do keyword ":" @@ -346,13 +347,13 @@ externDecl dvis return (map lift pars,pinfos,genArgs pars,tp,\body -> promote [] tpars [] (Just (Just teff, tres)) body) (exprs,rng) <- externalBody if (inline == InlineAlways) - then return [DefExtern (External name tp pinfos nameRng (combineRanges [krng,rng]) exprs vis doc)] + then return [DefExtern (External name tp pinfos nameRng (combineRanges [krng,rng]) exprs vis fip doc)] else do let externName = newHiddenExternalName name fullRng = combineRanges [krng,rng] - extern = External externName tp pinfos (before nameRng) (before fullRng) exprs Private doc + extern = External externName tp pinfos (before nameRng) (before fullRng) exprs Private fip doc body = annotate (Lam pars (App (Var externName False rangeNull) args fullRng) fullRng) binder = ValueBinder name () body nameRng fullRng - extfun = Def binder fullRng vis (defFun pinfos) InlineNever doc + extfun = Def binder fullRng vis (defFunEx pinfos fip) InlineNever doc return [DefExtern extern, DefValue extfun] where typeFromPars :: Range -> [ValueBinder UserType (Maybe UserExpr)] -> UserType -> UserType -> UserType @@ -563,8 +564,10 @@ structDecl dvis = (try $ do (vis,dvis,rng) <- do{ rng <- keyword "abstract"; return (Public,Private,rng) } <|> do{ (vis,rng) <- visibility dvis; return (vis,vis,rng) } - ddef <- do { specialId "value"; return (DataDefValue 0 0) } - <|> do { specialId "reference"; return DataDefNormal } + ddef <- do { specialId "value"; return (DataDefValue valueReprZero) } + <|> do { specialIdOr "ref" ["reference"]; + -- pwarningMessage "using 'reference' is deprecated and is always the default now"; + return DataDefNormal } <|> do { return DataDefAuto } (trng,doc) <- dockeyword "struct" return (vis,dvis,ddef,rng,trng,doc)) @@ -607,8 +610,9 @@ typeDeclKind try( do (ddef,isExtend) <- do { specialId "open"; return (DataDefOpen, False) } <|> do { specialId "extend"; return (DataDefOpen, True) } - <|> do { specialId "value"; return (DataDefValue 0 0, False) } - <|> do { specialId "reference"; return (DataDefNormal, False) } + <|> do { specialId "value"; return (DataDefValue valueReprZero, False) } + <|> do { specialIdOr "ref" ["reference"]; + return (DataDefNormal, False) } <|> return (DataDefAuto, False) (rng,doc) <- dockeyword "type" return (Inductive,rng,doc,ddef,isExtend)) @@ -818,14 +822,14 @@ makeEffectDecl decl = evName = newName "ev" evFld = ValueBinder evName evTp Nothing irng rng evCon = UserCon (toConstructorName id) [] [(Private,evFld)] Nothing irng rng Private "" - in (DataType ename tpars [evCon] rng vis Inductive (DataDefValue 0 0) False docx + in (DataType ename tpars [evCon] rng vis Inductive (DataDefNormal {-DataDefValue 0 0-}) False docx ,(\action -> Lam [ValueBinder evName Nothing Nothing irng rng] (App (action) [(Nothing,App (Var (toConstructorName id) False rng) [(Nothing,Var evName False rng)] rng)] rng) rng)) else let -- add a private constructor that refers to the handler type to get a proper recursion check hndfld = ValueBinder nameNil hndTp Nothing irng irng hndcon = UserCon (toConstructorName id) [hndEffTp,hndResTp] [(Private,hndfld)] Nothing irng irng Private "" - in (DataType ename tpars [hndcon] rng vis Inductive DataDefAuto False docx, \action -> action) + in (DataType ename tpars [hndcon] rng vis Inductive DataDefNormal False docx, \action -> action) -- declare the effect handler type kindEffect = KindCon nameKindEffect krng @@ -1090,7 +1094,7 @@ operationDecl opCount vis forallsScoped forallsNonScoped docEffect hndName effNa -- create a typed perform wrapper: fun op(x1:a1,..,xN:aN) : b { performN(evv-at(0),clause-op,x1,..,xN) } - opDef = let def = Def binder idrng vis (DefFun []) InlineAlways ("// call `" ++ show id ++ "` operation of the " ++ docEffect) + opDef = let def = Def binder idrng vis (defFun []) InlineAlways ("// call `" ++ show id ++ "` operation of the " ++ docEffect) nameRng = idrng binder = ValueBinder id () body nameRng nameRng body = Ann (Lam lparams innerBody rng) tpFull rng @@ -1149,23 +1153,51 @@ operationDecl opCount vis forallsScoped forallsNonScoped docEffect hndName effNa pureDecl :: Visibility -> LexParser UserDef pureDecl dvis - = do (vis,vrng,rng,doc,inline,isVal) + = do pdecl <- try $ do (vis,vrng) <- visibility dvis inline <- parseInline - (do (rng,doc) <- dockeywordFun; return (vis,vrng,rng,doc,inline,False) + (do (rng,doc) <- dockeyword "val" -- return (vis,vrng,rng,doc,inline,True) + return (valDecl (combineRange vrng rng) doc vis inline) <|> - do (rng,doc) <- dockeyword "val"; return (vis,vrng,rng,doc,inline,True) + do fip <- parseFip + (rng,doc) <- dockeywordFun -- return (vis,vrng,rng,doc,inline,False) + return (funDecl (combineRange vrng rng) doc vis inline fip) <|> do keyword "fn" fail "hint: use 'fun' to start a named function definition (and 'fn' for anonymous functions)") - (if isVal then valDecl else funDecl) (combineRange vrng rng) doc vis inline + -- (if isVal then valDecl else funDecl) (combineRange vrng rng) doc vis inline -- valueDecl vrng vis <|> functionDecl vrng vis + pdecl + +parseFipAlloc :: LexParser FipAlloc +parseFipAlloc + = parens ( (do (num,_) <- integer + return (AllocAtMost (fromInteger num))) + <|> do _ <- specialId "n" + return AllocFinitely) + <|> return (AllocAtMost 0) + +parseFip :: LexParser Fip +parseFip + = do isTail <- do specialId "tail" + return True + <|> return False + ( do specialId "fip" + alloc <- parseFipAlloc + when isTail $ pwarningMessage "a 'fip' function implies already 'tail'" + return (Fip alloc) + <|> + do specialId "fbip" + alloc <- parseFipAlloc + return (Fbip alloc isTail) + <|> return (NoFip isTail)) functionDecl vrng vis - = do (rng,doc,inline) <- try $ do inline <- parseInline - (rng,doc) <- dockeywordFun - return (rng,doc,inline) - funDecl (combineRange vrng rng) doc vis inline + = do pdecl <- try $ do inline <- parseInline + fip <- parseFip + (rng,doc) <- dockeywordFun + return (funDecl (combineRange vrng rng) doc vis inline fip) + pdecl varDecl = do (vrng,doc) <- dockeyword "var" @@ -1181,7 +1213,7 @@ valDecl rng doc vis inline body <- blockexpr return (Def (bind body) (combineRanged rng body) vis DefVal inline doc) -funDecl rng doc vis inline +funDecl rng doc vis inline fip = do spars <- squantifier -- tpars <- aquantifier -- todo: store somewhere (name,nameRng) <- funid @@ -1189,7 +1221,8 @@ funDecl rng doc vis inline body <- bodyexpr let fun = promote spars tpars preds mbtres (Lam pars body (combineRanged rng body)) - return (Def (ValueBinder name () (ann fun) nameRng nameRng) (combineRanged rng fun) vis (defFun pinfos) inline doc) + return (Def (ValueBinder name () (ann fun) nameRng nameRng) (combineRanged rng fun) vis + (defFunEx pinfos fip) inline doc) -- fundef: forall parameters, parameters, (effecttp, resulttp), annotation funDef :: Bool -> LexParser ([TypeBinder UserKind],[ValueBinder (Maybe UserType) (Maybe UserExpr)], [ParamInfo], Range, Maybe (Maybe UserType, UserType),[UserType], UserExpr -> UserExpr) @@ -1866,9 +1899,16 @@ appexpr allowTrailingLam indexer = do rng0 <- lidx - idxs <- sepBy1 expr comma - rng1 <- special "]" - return (\exp -> App (Var nameIndex False (combineRange rng0 rng1)) (map (\a -> (Nothing,a)) (exp:idxs)) (combineRange rng0 rng1)) + (do crng <- keyword "ctx" + ctx <- ccontext crng + rng1 <- special "]" + return (\exp -> let rng = combineRanged exp rng1 + in App (Var nameCCtxComposeExtend False rng) [(Nothing,exp),(Nothing,ctx)] rng) + <|> + do idxs <- sepBy1 expr comma + rng1 <- special "]" + return (\exp -> App (Var nameIndex False (combineRange rng0 rng1)) (map (\a -> (Nothing,a)) (exp:idxs)) (combineRange rng0 rng1)) + ) applier = do rng0 <- lapp @@ -1918,6 +1958,10 @@ atom <|> do lit <- literal return (Lit lit) + <|> + do cctxHole + <|> + do cctxExpr <|> do injectExpr "(simple) expression" @@ -1970,6 +2014,21 @@ listExpr makeNil rng = Var nameNull False rng makeCons rng x xs = makeApp (Var nameCons False rng) [x,xs] +cctxExpr :: LexParser UserExpr +cctxExpr + = do rng <- keyword "ctx" + ccontext rng + +ccontext :: Range -> LexParser UserExpr +ccontext rng + = do ctx <- ntlexpr + return (makeApp (Var nameCCtxCreate False rng) [ctx]) + +cctxHole :: LexParser UserExpr +cctxHole + = do rng <- keyword "hole" <|> do { (_,r) <- wildcard; return r } + return (makeApp (Var nameCCtxHoleCreate False rng) []) + injectExpr :: LexParser UserExpr injectExpr @@ -2308,7 +2367,7 @@ anntypek return tp) tid - = do (id,rng) <- qvarid + = do (id,rng) <- qvarid <|> typeidCtx return (if isTypeVar id then TpVar id rng else TpCon id rng) <|> do (id,rng) <- wildcard "" @@ -2643,17 +2702,21 @@ ensureUnqualified entity p ----------------------------------------------------------- -- Lexical tokens ----------------------------------------------------------- -qtypeid :: LexParser (Name,Range) +qtypeid, typeidCtx :: LexParser (Name,Range) qtypeid = try $ do pos <- getPosition - (name,range) <- qvarid + (name,range) <- qvarid <|> typeidCtx if (not (isTypeVar name)) then return (name,range) else -- trace ("not a qtype: " ++ show name) $ do setPosition pos mzero "type name (and not type variable)" +typeidCtx + = do r <- keyword "ctx" + return (newName "ctx",r) + qop :: LexParser (Name,Range) qop = do (Lexeme rng (LexOp id)) <- parseLex (LexOp nameNil) @@ -2767,6 +2830,15 @@ special s show s +specialIdOr :: String -> [String] -> LexParser Range +specialIdOr kw [] = specialId kw +specialIdOr kw deprecated + = choice (specialId kw : map deprecate deprecated) + where + deprecate k = do rng <- specialId k + warnDeprecated k kw + return rng + keywordOr :: String -> [String] -> LexParser Range keywordOr kw [] = keyword kw diff --git a/src/Syntax/Syntax.hs b/src/Syntax/Syntax.hs index 6b5e16287..f7e8fc1d6 100644 --- a/src/Syntax/Syntax.hs +++ b/src/Syntax/Syntax.hs @@ -67,6 +67,7 @@ data External , extRange :: Range , extInline :: [(Target,ExternalCall)] -- map: target inline , extVis :: Visibility + , extFip :: Fip , extDoc :: String } | ExternalImport{ extImport :: [(Target,[(String,String)])] @@ -283,6 +284,15 @@ data Lit | LitString String Range deriving (Show) + +stripExpr :: Expr t -> Expr t +stripExpr (Parens e _ _) = stripExpr e +stripExpr (Ann e _ _) = stripExpr e +stripExpr e = e + + + + {-------------------------------------------------------------------------- types and Kinds --------------------------------------------------------------------------} @@ -325,8 +335,8 @@ instance Ranged (TypeDef t u k) where = typeDefRange typeDef instance Ranged t => Ranged (Def t) where - getRange (Def binder nameTypeRange _ _ _ _) - = getRange binder + getRange def + = getRange (defBinder def) instance Ranged (ValueBinder t e) where getRange vb = binderRange vb @@ -443,7 +453,7 @@ instance HasName (ValueBinder t e) where getRName vb = (binderName vb,binderNameRange vb) instance HasName (Def t) where - getRName (Def vb range _ _ _ _) = getRName vb + getRName def = getRName (defBinder def) @@ -482,10 +492,10 @@ instance HasFreeTypeVar a => HasFreeTypeVar (Either a b) where Access definitions --------------------------------------------------------------------------} defBody :: Def t -> Expr t -defBody (Def vb _ _ _ _ _) = binderExpr vb +defBody def = binderExpr (defBinder def) defName :: Def t -> Name -defName (Def vb _ _ _ _ _) = binderName vb +defName def = binderName (defBinder def) defType :: Def t -> Maybe t defType def diff --git a/src/Type/Assumption.hs b/src/Type/Assumption.hs index 989b258d5..ec786fefb 100644 --- a/src/Type/Assumption.hs +++ b/src/Type/Assumption.hs @@ -18,15 +18,17 @@ module Type.Assumption ( , gammaMap , gammaList , gammaIsEmpty - , gammaNames + , gammaNames, gammaPublicNames , ppGamma, ppGammaHidden, gammaRemove, gammaUnion, gammaUnions , gammaFilter , isInfoCon , isInfoImport , isInfoFun , isInfoValFunExt + , isInfoFunOrExternal , infoElement , infoCanonicalName + , fipFromNameInfo -- * From Core , extractGammaImports , extractGamma @@ -39,7 +41,7 @@ module Type.Assumption ( import Lib.Trace import Common.Range import Common.Failure -import Common.Syntax( DefSort(..), isDefFun ) +import Common.Syntax( DefSort(..), isDefFun, defFun, Fip, noFip ) import qualified Data.List as L import Lib.PPrint import qualified Common.NameMap as M @@ -56,9 +58,9 @@ import Lib.Trace data NameInfo = InfoVal{ infoVis :: Visibility, infoCName :: Name, infoType :: Scheme, infoRange :: Range, infoIsVar :: Bool } - | InfoFun{ infoVis :: Visibility, infoCName :: Name, infoType :: Scheme, infoArity :: (Int,Int), infoRange :: Range } + | InfoFun{ infoVis :: Visibility, infoCName :: Name, infoType :: Scheme, infoArity :: (Int,Int), infoFip :: Fip, infoRange :: Range } | InfoCon{ infoVis :: Visibility, infoType :: Scheme, infoRepr :: Core.ConRepr, infoCon :: ConInfo, infoRange :: Range } - | InfoExternal{ infoVis :: Visibility, infoCName :: Name, infoType :: Scheme, infoFormat :: [(Target,String)], infoRange :: Range } + | InfoExternal{ infoVis :: Visibility, infoCName :: Name, infoType :: Scheme, infoFormat :: [(Target,String)], infoFip :: Fip, infoRange :: Range } | InfoImport{ infoVis :: Visibility, infoType :: Scheme, infoAlias :: Name, infoFullName :: Name, infoRange :: Range } deriving (Show) @@ -88,6 +90,17 @@ isInfoFun :: NameInfo -> Bool isInfoFun (InfoFun{}) = True isInfoFun _ = False +isInfoFunOrExternal :: NameInfo -> Bool +isInfoFunOrExternal (InfoFun{}) = True +isInfoFunOrExternal (InfoExternal{}) = True +isInfoFunOrExternal _ = False + +fipFromNameInfo :: NameInfo -> Fip +fipFromNameInfo (InfoFun{infoFip=fip}) = fip +fipFromNameInfo (InfoExternal{infoFip=fip}) = fip +fipFromNameInfo _ = noFip + + infoElement :: NameInfo -> String infoElement info = case info of @@ -104,19 +117,19 @@ infoIsVisible info = case infoVis info of coreVarInfoFromNameInfo :: NameInfo -> Core.VarInfo coreVarInfoFromNameInfo info = case info of - InfoVal _ _ tp _ _ -> Core.InfoNone - InfoFun _ _ tp (m,n) _ -> Core.InfoArity m n - InfoExternal _ _ tp format _ -> Core.InfoExternal format - _ -> matchFailure "Type.Infer.coreVarInfoFromNameInfo" + InfoVal _ _ tp _ _ -> Core.InfoNone + InfoFun _ _ tp (m,n) _ _ -> Core.InfoArity m n + InfoExternal _ _ tp format _ _ -> Core.InfoExternal format + _ -> matchFailure "Type.Infer.coreVarInfoFromNameInfo" coreExprFromNameInfo qname info = -- trace ("create name: " ++ show qname) $ case info of - InfoVal vis cname tp _ _ -> Core.Var (Core.TName cname tp) (Core.InfoNone) - InfoFun vis cname tp ((m,n)) _ -> Core.Var (Core.TName cname tp) (Core.InfoArity m n) - InfoCon vis tp repr _ _ -> Core.Con (Core.TName qname tp) repr - InfoExternal vis cname tp format _ -> Core.Var (Core.TName cname tp) (Core.InfoExternal format) - InfoImport _ _ _ _ _ -> matchFailure "Type.Infer.coreExprFromNameInfo" + InfoVal vis cname tp _ _ -> Core.Var (Core.TName cname tp) (Core.InfoNone) + InfoFun vis cname tp ((m,n)) _ _ -> Core.Var (Core.TName cname tp) (Core.InfoArity m n) + InfoCon vis tp repr _ _ -> Core.Con (Core.TName qname tp) repr + InfoExternal vis cname tp format _ _ -> Core.Var (Core.TName cname tp) (Core.InfoExternal format) + InfoImport _ _ _ _ _ -> matchFailure "Type.Infer.coreExprFromNameInfo" {-------------------------------------------------------------------------- @@ -234,6 +247,10 @@ gammaNames :: Gamma -> [Name] gammaNames (Gamma g) = M.keys g +gammaPublicNames :: Gamma -> [Name] +gammaPublicNames (Gamma g) + = [name | (name,ninfos) <- M.toList g, all (infoIsVisible . snd) ninfos && not (isHiddenName name)] + {--------------------------------------------------------------- Extract from core ---------------------------------------------------------------} @@ -299,10 +316,13 @@ coreDefInfo def@(Core.Def name tp expr vis sort inl nameRng doc) createNameInfoX :: Visibility -> Name -> DefSort -> Range -> Type -> NameInfo createNameInfoX vis name sort rng tp = -- trace ("createNameInfoX: " ++ show name ++ ", " ++ show sort ++ ": " ++ show (pretty tp)) $ - if (not (isDefFun sort)) then InfoVal vis name tp rng (sort == DefVar) else InfoFun vis name tp (getArity tp) rng + case sort of + DefFun _ fip -> InfoFun vis name tp (getArity tp) fip rng + DefVar -> InfoVal vis name tp rng True + _ -> InfoVal vis name tp rng False createNameInfo name isVal rng tp - = createNameInfoX Public name (if isVal then DefVal else DefFun []) rng tp + = createNameInfoX Public name (if isVal then DefVal else defFun []) rng tp -- if (isVal) then InfoVal name tp rng False else InfoFun name tp (getArity tp) rng getArity :: Type -> (Int,Int) @@ -316,8 +336,8 @@ getArity tp _ -> failure ("Type.Assumption.createNameInfo.getArity: illegal type?" ++ show tp) -extractExternal updateVis (Core.External name tp pinfos body vis nameRng doc) - = gammaSingle (nonCanonicalName name) (InfoExternal (updateVis vis) name tp body nameRng) +extractExternal updateVis (Core.External name tp pinfos body vis fip nameRng doc) + = gammaSingle (nonCanonicalName name) (InfoExternal (updateVis vis) name tp body fip nameRng) extractExternal updateVis _ = gammaEmpty diff --git a/src/Type/Infer.hs b/src/Type/Infer.hs index 8f8081b06..a67dee114 100644 --- a/src/Type/Infer.hs +++ b/src/Type/Infer.hs @@ -39,6 +39,7 @@ import Common.NamePrim( nameTpOptional, nameOptional, nameOptionalNone, nameCopy , nameTpValueOp, nameClause, nameIdentity , nameMaskAt, nameMaskBuiltin, nameEvvIndex, nameHTag, nameTpHTag , nameInt32, nameOr, nameAnd, nameEffectOpen + , nameCCtxCreate, nameCCtxHoleCreate, isNameTuple ) import Common.Range import Common.Unique @@ -65,11 +66,12 @@ import Type.InferMonad import qualified Core.CoreVar as CoreVar import Core.AnalysisMatch( analyzeBranches ) +import Core.AnalysisCCtx( analyzeCCtx ) -- import Common.ResumeKind -- import Core.AnalysisResume( analyzeResume ) import Core.Divergent( analyzeDivergence ) import Core.BindingGroups( regroup ) -import Core.Simplify( uniqueSimplify ) +-- import Core.Simplify( uniqueSimplify ) import qualified Syntax.RangeMap as RM @@ -145,7 +147,7 @@ inferDefGroup topLevel (DefRec defs) cont = -- trace ("\ninfer group: " ++ show (map defName defs)) $ do (gamma,infgamma) <- createGammas [] [] defs --coreDefs0 <- extendGamma gamma (mapM (inferRecDef topLevel infgamma) defs) - (coreDefsX,assumed) <- extendGamma False gamma $ extendInfGamma topLevel infgamma $ + (coreDefsX,assumed) <- extendGamma False gamma $ extendInfGammaEx topLevel [] infgamma $ do assumed <- mapM (\def -> lookupInfName (getName def)) defs coreDefs0 <- mapM (\def -> inferDef Instantiated def) defs coreDefs1 <- mapM fixCanonicalName coreDefs0 @@ -343,7 +345,7 @@ inferRecDef2 topLevel coreDef divergent (def,mbAssumed) -> -- fix it up by adding the polymorphic type application do assumedTpX <- subst assumedTp >>= normalize True -- resTp0 -- resTpX <- subst resTp0 >>= normalize - simexpr <- liftUnique $ uniqueSimplify penv False False 1 {-runs-} 0 expr + simexpr <- return expr -- liftUnique $ uniqueSimplify penv False False 1 {-runs-} 0 expr coreX <- subst simexpr let -- coreX = simplify expr -- coref0 (Core.defExpr coreDef) mvars = [TypeVar id kind Bound | TypeVar id kind _ <- tvars] @@ -366,13 +368,13 @@ inferRecDef2 topLevel coreDef divergent (def,mbAssumed) -} (Just (_,_), _) | divergent -- we added a divergent effect, fix up the occurrences of the assumed type -> do assumedTpX <- normalize True assumedTp >>= subst -- resTp0 - simResCore1 <- liftUnique $ uniqueSimplify penv False False 1 0 resCore1 + simResCore1 <- return resCore1 -- liftUnique $ uniqueSimplify penv False False 1 0 resCore1 coreX <- subst simResCore1 let resCoreX = (CoreVar.|~>) [(Core.TName ({- unqualify -} name) assumedTpX, Core.Var (Core.TName ({- unqualify -} name) resTp1) info)] coreX return (resTp1, resCoreX) (Just _,_) -- ensure we insert the right info (test: static/div2-ack) -> do assumedTpX <- normalize True assumedTp >>= subst - simResCore1 <- liftUnique $ uniqueSimplify penv False False 1 0 resCore1 + simResCore1 <- return resCore1 -- liftUnique $ uniqueSimplify penv False False 1 0 resCore1 coreX <- subst simResCore1 let resCoreX = (CoreVar.|~>) [(Core.TName ({- unqualify -} name) assumedTpX, Core.Var (Core.TName ({- unqualify -} name) resTp1) info)] coreX return (resTp1, resCoreX) @@ -391,7 +393,7 @@ inferRecDef topLevel infgamma def do let rng = defRange def nameRng = binderNameRange (defBinder def) eitherRes <- - extendInfGamma topLevel infgamma $ + extendInfGammaEx topLevel [] infgamma $ do mbAssumedType <- lookupInfName (getName def) coreDef <- inferDef Instantiated def case mbAssumedType of @@ -444,7 +446,7 @@ inferDef expect (Def (ValueBinder name mbTp expr nameRng vrng) rng vis sort inl if (verbose penv >= 3) then Lib.Trace.trace ("infer: " ++ show sort ++ " " ++ show name) $ return () else return () - withDefName name $ + withDefName name $ disallowHole $ (if (not (isDefFun sort) || nameIsNil name) then id else allowReturn True) $ do (tp,eff,coreExpr) <- inferExpr Nothing expect expr -- Just annTp -> inferExpr (Just (annTp,rng)) (if (isRho annTp) then Instantiated else Generalized) (Ann expr annTp rng) @@ -461,7 +463,7 @@ inferDef expect (Def (ValueBinder name mbTp expr nameRng vrng) rng vis sort inl inferBindDef :: Def Type -> Inf (Effect,Core.Def) inferBindDef (Def (ValueBinder name () expr nameRng vrng) rng vis sort inl doc) = -- trace ("infer bind def: " ++ show name ++ ", var?:" ++ show (sort==DefVar)) $ - do withDefName name $ + do withDefName name $ disallowHole $ do (tp,eff,coreExpr) <- inferExpr Nothing Instantiated expr stp <- subst tp -- Just annTp -> inferExpr (Just (annTp,rng)) Instantiated (Ann expr annTp rng) @@ -532,6 +534,7 @@ inferIsolated contextRange range body inf inferExpr :: Maybe (Type,Range) -> Expect -> Expr Type -> Inf (Type,Effect,Core.Expr) inferExpr propagated expect (Lam binders body rng) = isNamedLam $ \isNamed -> + disallowHole $ do -- traceDoc $ \env -> text " inferExpr.Lam:" <+> pretty (show expect) <+> text ", propagated:" <+> ppProp env propagated (propArgs,propEff,propBody,skolems,expectBody) <- matchFun (length binders) propagated @@ -550,8 +553,8 @@ inferExpr propagated expect (Lam binders body rng) Nothing -> Op.freshTVar kindStar Meta Just (tp,_) -> return tp - (tp,eff1,core) <- extendInfGamma False infgamma $ - extendInfGamma False [(nameReturn,createNameInfoX Public nameReturn DefVal (getRange body) returnTp)] $ + (tp,eff1,core) <- extendInfGamma infgamma $ + extendInfGamma [(nameReturn,createNameInfoX Public nameReturn DefVal (getRange body) returnTp)] $ (if (isNamed) then inferIsolated rng (getRange body) body else id) $ -- inferIsolated rng (getRange body) body $ inferExpr propBody expectBody body @@ -674,7 +677,7 @@ inferExpr propagated expect (App assign@(Var name _ arng) [lhs@(_,lval),rhs@(_,r where errorAssignable = do contextError rng (getRange lval) (text "not an assignable expression") [(text "because",text "an assignable expression must be an application, index expression, or variable")] - return (typeUnit,typeTotal,Core.Con (Core.TName (nameTuple 0) typeUnit) (Core.ConEnum nameTpUnit Core.DataEnum 0)) + return (typeUnit,typeTotal,Core.Con (Core.TName (nameTuple 0) typeUnit) (Core.ConEnum nameTpUnit Core.DataEnum valueReprZero 0)) checkAssign = Check "an assignable identifier must have a reference type" @@ -709,6 +712,34 @@ inferExpr propagated expect (App (h@Handler{hndlrAllowMask=Nothing}) [action] rn inferExpr propagated expect (App (Var byref _ _) [(_,Var name _ rng)] _) | byref == nameByref = inferVar propagated expect name rng False +-- | Hole expressions +inferExpr propagated expect (App fun@(Var hname _ _) [] rng) | hname == nameCCtxHoleCreate + = do ok <- useHole + when (not ok) $ + contextError rng rng (text "ill-formed constructor context") + [(text "because",text "there can be only one hole, and it must occur under a constructor context 'ctx'")] + inferApp propagated expect fun [] rng + +-- | Context expressions +inferExpr propagated expect (App (Var ctxname _ nameRng) [(_,expr)] rng) | ctxname == nameCCtxCreate + = do tpv <- Op.freshTVar kindStar Meta + holetp <- Op.freshTVar kindStar Meta + let ctxTp = TApp typeCCtxx [tpv,holetp] + prop <- case propagated of + Nothing -> return Nothing + Just (ctp,crng) -> do inferUnify (checkMatch crng) nameRng ctp ctxTp + stp <- subst tpv + return (Just (stp,rng)) + ((tp,eff,core),hole) <- allowHole $ inferExpr prop Instantiated expr + inferUnify (Infer rng) nameRng tp tpv + when (not hole) $ + contextError rng rng (text "ill-formed constructor context") [(text "because",text "the context has no 'hole'")] + newtypes <- getNewtypes + score <- subst core + (ccore,errs) <- withUnique (analyzeCCtx rng newtypes score) + mapM_ (\(rng,err) -> infError rng err) errs + return (Core.typeOf ccore,eff,ccore) + -- | Application nodes. Inference is complicated here since we need to disambiguate overloaded identifiers. inferExpr propagated expect (App fun nargs rng) = inferApp propagated expect fun nargs rng @@ -767,17 +798,19 @@ inferExpr propagated expect (Handler handlerSort scoped HandlerOverride mbAllowM inferExpr propagated expect (Case expr branches rng) = -- trace " inferExpr.Case" $ - do (ctp,ceff,ccore) <- allowReturn False $ inferExpr Nothing Instantiated expr + do (ctp,ceff,ccore) <- allowReturn False $ disallowHole $ inferExpr Nothing Instantiated expr -- infer branches - bress <- case (propagated,branches) of + bress <- disallowHole $ + let matchedNames = extractMatchedNames expr in + case (propagated,branches) of (Nothing,(b:bs)) -> -- propagate the type of the first branch - do bres@(tpeffs,_) <- inferBranch propagated ctp (getRange expr) b + do bres@(tpeffs,_) <- inferBranch propagated ctp (getRange expr) matchedNames b let tp = case tpeffs of (tp,_):_ -> tp _ -> failure $ "Type.Infer.inferExpr.Case: branch without guard" - bress <- mapM (inferBranch (Just (tp,getRange b)) ctp (getRange expr)) bs + bress <- mapM (inferBranch (Just (tp,getRange b)) ctp (getRange expr) matchedNames) bs return (bres:bress) - _ -> mapM (inferBranch propagated ctp (getRange expr)) branches + _ -> mapM (inferBranch propagated ctp (getRange expr) matchedNames) branches let (tpeffss,bcores) = unzip bress (tps,effs) = unzip (concat tpeffss) -- ensure branches match @@ -831,6 +864,18 @@ inferExpr propagated expect (Case expr branches rng) _ -> failure ("Type.Infer.inferExpr.Case.getTypeName: not a valid scrutinee? " ++ show tp) + extractMatchedNames expr + = case expr of + Parens e _ _ -> extractMatchedNames e + App (Var tname _ _) args _ | isNameTuple tname -> concat (map (extractMatchedNamesX . snd) args) + _ -> extractMatchedNamesX expr + + extractMatchedNamesX expr + = case expr of + Var name _ _ -> [name] + _ -> [] + + inferExpr propagated expect (Var name isOp rng) = inferVar propagated expect name rng True @@ -1244,7 +1289,7 @@ inferApp propagated expect fun nargs rng if (Core.isTotal fcore) then return (Core.makeLet defs (coreApp fcore cargs)) else do fname <- uniqueName "fun" - let fdef = Core.DefNonRec (Core.Def fname ftp fcore Core.Private (DefFun [] {-all own, TODO: maintain borrow annotations?-}) InlineAuto rangeNull "") + let fdef = Core.DefNonRec (Core.Def fname ftp fcore Core.Private (defFun [] {-all own, TODO: maintain borrow annotations?-}) InlineAuto rangeNull "") fvar = Core.Var (Core.TName fname ftp) Core.InfoNone return (Core.Let (fdef:defs) (coreApp fvar cargs)) -- take top effect @@ -1408,9 +1453,13 @@ inferApp propagated expect fun nargs rng topEff <- inferUnifies (checkEffect rng) ((getRange fun, eff1) : effArgs) inferUnify (checkEffectSubsume rng) (getRange fun) funEff topEff + let appexpr = case shortCircuit fcore coreArgs of + Just cexpr -> cexpr + Nothing -> Core.App fcore coreArgs + -- instantiate or generalize result type resTp1 <- subst expTp - (resTp,resCore) <- maybeInstantiateOrGeneralize rng (getRange fun) topEff expect resTp1 (Core.App fcore coreArgs) + (resTp,resCore) <- maybeInstantiateOrGeneralize rng (getRange fun) topEff expect resTp1 appexpr return (resTp,topEff,resCore ) fst3 (x,y,z) = x @@ -1499,8 +1548,8 @@ inferVarX propagated expect name rng qname1 tp1 info1 return (itp,eff,coref coreVar) -} -inferBranch :: Maybe (Type,Range) -> Type -> Range -> Branch Type -> Inf ([(Type,Effect)],Core.Branch) -inferBranch propagated matchType matchRange branch@(Branch pattern guards) +inferBranch :: Maybe (Type,Range) -> Type -> Range -> [Name] -> Branch Type -> Inf ([(Type,Effect)],Core.Branch) +inferBranch propagated matchType matchRange matchedNames branch@(Branch pattern guards) = inferPattern matchType (getRange branch) pattern ( \pcore gcores -> -- check for unused pattern bindings @@ -1515,7 +1564,7 @@ inferBranch propagated matchType matchRange branch@(Branch pattern guards) ) $ \infGamma -> -- infGamma <- extractInfGamma pcore - extendInfGamma False infGamma $ + extendInfGammaEx False matchedNames infGamma $ do -- check guard expressions unzip <$> mapM (inferGuard propagated (getRange branch)) guards @@ -1722,7 +1771,7 @@ inferOptionals eff infgamma (par:pars) partp <- subst tvar -- infer expression - (exprTp,exprEff,coreExpr) <- extendInfGamma False infgamma $ inferExpr (Just (partp,getRange par)) + (exprTp,exprEff,coreExpr) <- extendInfGamma infgamma $ inferExpr (Just (partp,getRange par)) (if isRho partp then Instantiated else Generalized False) expr inferUnify (checkOptional fullRange) (getRange expr) partp exprTp @@ -2231,19 +2280,21 @@ usesLocalsOp lvars b = usesLocals lvars (hbranchExpr b) shortCircuit :: Core.Expr -> [Core.Expr] -> Maybe Core.Expr shortCircuit fun [expr1,expr2] - = case fun of - Core.App (Core.TypeApp (Core.Var open _) _) [Core.Var name _] | Core.getName open == nameEffectOpen && Core.getName name == nameAnd - -> exprAnd - Core.App (Core.TypeApp (Core.Var open _) _) [Core.Var name _] | Core.getName open == nameEffectOpen && Core.getName name == nameOr - -> exprOr - Core.Var name _ | Core.getName name == nameAnd - -> exprAnd - Core.Var name _ | Core.getName name == nameOr - -> exprOr - _ -> Nothing + = isAndOr fun where exprAnd = Just (Core.makeIfExpr expr1 expr2 Core.exprFalse) exprOr = Just (Core.makeIfExpr expr1 Core.exprTrue expr2) + isAndOr expr + = case expr of + Core.App (Core.TypeApp (Core.Var open _) _) [body] | Core.getName open == nameEffectOpen + -> isAndOr body + Core.Var name _ | Core.getName name == nameAnd + -> exprAnd + Core.Var name _ | Core.getName name == nameOr + -> exprOr + _ -> Nothing + + shortCircuit fun args = Nothing \ No newline at end of file diff --git a/src/Type/InferMonad.hs b/src/Type/InferMonad.hs index 2ad88aaa3..6031a7973 100644 --- a/src/Type/InferMonad.hs +++ b/src/Type/InferMonad.hs @@ -16,7 +16,7 @@ module Type.InferMonad( Inf, InfGamma -- * Environment , getGamma , extendGamma, extendGammaCore - , extendInfGamma, extendInfGammaCore + , extendInfGamma, extendInfGammaEx, extendInfGammaCore , withGammaType -- * Name resolution @@ -39,6 +39,7 @@ module Type.InferMonad( Inf, InfGamma -- * Misc. , allowReturn, isReturnAllowed + , useHole, allowHole, disallowHole , withLhs, isLhs , getPrettyEnv , splitEffect @@ -840,15 +841,16 @@ data Env = Env{ prettyEnv :: !Pretty.Env , gamma :: !Gamma , infgamma :: !InfGamma , imports :: !ImportMap - , returnAllowed :: Bool - , inLhs :: Bool + , returnAllowed :: !Bool + , inLhs :: !Bool } -data St = St{ uniq :: !Int, sub :: !Sub, preds :: ![Evidence], mbRangeMap :: Maybe RangeMap } +data St = St{ uniq :: !Int, sub :: !Sub, preds :: ![Evidence], holeAllowed :: !Bool, mbRangeMap :: Maybe RangeMap } runInfer :: Pretty.Env -> Maybe RangeMap -> Synonyms -> Newtypes -> ImportMap -> Gamma -> Name -> Int -> Inf a -> Error (a,Int,Maybe RangeMap) runInfer env mbrm syns newTypes imports assumption context unique (Inf f) - = case f (Env env context (newName "") False newTypes syns assumption infgammaEmpty imports False False) (St unique subNull [] mbrm) of + = case f (Env env context (newName "") False newTypes syns assumption infgammaEmpty imports False False) + (St unique subNull [] False mbrm) of Err err warnings -> addWarnings warnings (errorMsg (ErrorType [err])) Ok x st warnings -> addWarnings warnings (ok (x, uniq st, (sub st) |-> mbRangeMap st)) @@ -867,11 +869,11 @@ instance Functor Inf where Err err w -> Err err w) instance Applicative Inf where - pure = return - (<*>) = ap + pure x = Inf (\env st -> Ok x st []) + (<*>) = ap instance Monad Inf where - return x = Inf (\env st -> Ok x st []) + -- return = pure (Inf i) >>= f = Inf (\env st0 -> case i env st0 of Ok x st1 w1 -> case f x of Inf j -> case j env st1 of @@ -953,6 +955,27 @@ isReturnAllowed = do env <- getEnv return (returnAllowed env) +useHole :: Inf Bool +useHole + = do st0 <- updateSt (\st -> st{ holeAllowed = False } ) + return (holeAllowed st0) + +disallowHole :: Inf a -> Inf a +disallowHole action + = do st0 <- updateSt(\st -> st{ holeAllowed = False }) + let prev = holeAllowed st0 + x <- action + updateSt(\st -> st{ holeAllowed = prev }) + return x + +allowHole :: Inf a -> Inf (a,Bool {- was the hole used? -}) +allowHole action + = do st0 <- updateSt(\st -> st{ holeAllowed = True }) + let prev = holeAllowed st0 + x <- action + st1 <- updateSt(\st -> st{ holeAllowed = prev }) + return (x,not (holeAllowed st1)) + getSub :: Inf Sub @@ -1051,15 +1074,19 @@ extendInfGammaCore :: Bool -> [Core.DefGroup] -> Inf a -> Inf a extendInfGammaCore topLevel [] inf = inf extendInfGammaCore topLevel (coreDefs:coreDefss) inf - = extendInfGamma topLevel (extracts coreDefs) (extendInfGammaCore topLevel coreDefss inf) + = extendInfGammaEx topLevel [] (extracts coreDefs) (extendInfGammaCore topLevel coreDefss inf) where extracts (Core.DefRec defs) = map extract defs extracts (Core.DefNonRec def) = [extract def] extract def = coreDefInfo def -- (Core.defName def,(Core.defNameRange def, Core.defType def, Core.defSort def)) -extendInfGamma :: Bool -> [(Name,NameInfo)] -> Inf a -> Inf a -extendInfGamma topLevel tnames inf +extendInfGamma :: [(Name,NameInfo)] -> Inf a -> Inf a +extendInfGamma tnames inf + = extendInfGammaEx False [] tnames inf + +extendInfGammaEx :: Bool -> [Name] -> [(Name,NameInfo)] -> Inf a -> Inf a +extendInfGammaEx topLevel ignores tnames inf = do env <- getEnv infgamma' <- extend (context env) (gamma env) [] [(unqualify name,info) | (name,info) <- tnames, not (isWildcard name)] (infgamma env) withEnv (\env -> env{ infgamma = infgamma' }) inf @@ -1082,7 +1109,7 @@ extendInfGamma topLevel tnames inf Just info2 | infoCanonicalName name info2 /= nameReturn -> do checkCasingOverlap range name (infoCanonicalName name info2) info2 env <- getEnv - if (not (isHiddenName name) && show name /= "resume" && show name /= "resume-shallow") + if (not (isHiddenName name) && show name /= "resume" && show name /= "resume-shallow" && not (name `elem` ignores)) then infWarning range (Pretty.ppName (prettyEnv env) name <+> text "shadows an earlier local definition or parameter") else return () _ -> return () @@ -1098,7 +1125,7 @@ withGammaType :: Range -> Type -> Inf a -> Inf a withGammaType range tp inf = do defName <- currentDefName name <- uniqueName (show defName) - extendInfGamma False [(name,(InfoVal Public name tp range False))] inf + extendInfGamma [(name,(InfoVal Public name tp range False))] inf currentDefName :: Inf Name currentDefName diff --git a/src/Type/Kind.hs b/src/Type/Kind.hs index 94db9fe39..40b29de13 100644 --- a/src/Type/Kind.hs +++ b/src/Type/Kind.hs @@ -135,8 +135,8 @@ instance HasKind Type where TCon c -> getKind c TSyn syn xs tp -> -- getKind tp {- this is wrong for partially applied type synonym arguments, see "kind/alias3" test -} -- if (null xs) then getKind tp else - kindApply xs (getKind syn) - TApp tp args -> kindApply args (getKind tp) + kindApply xs (getKind syn) + TApp tp args -> kindApply args (getKind tp) {- case collect [] (getKind tp) of (kres:_) -> kres _ -> failure ("Type.Kind: illegal kind in type application? " ++ show (getKind tp) ) @@ -148,4 +148,5 @@ instance HasKind Type where kindApply [] k = k kindApply (_:rest) (KApp (KApp arr k1) k2) = kindApply rest k2 - kindApply _ k = failure ("Type.Kind.kindApply: illegal kind in application? " ++ show k) + kindApply args k = failure ("Type.Kind.kindApply: illegal kind in application? " ++ show (k) ++ " to " ++ show args + ++ "\n " ++ show tau) diff --git a/src/Type/Pretty.hs b/src/Type/Pretty.hs index d4558660d..82b075f74 100644 --- a/src/Type/Pretty.hs +++ b/src/Type/Pretty.hs @@ -244,7 +244,7 @@ prettyDataInfo env0 showBody publicOnly isExtend info@(DataInfo datakind name ki else case datadef of DataDefRec -> text "recursive " DataDefOpen -> text "open " - DataDefValue m n -> text ("value{" ++ show m ++ "," ++ show n ++ "} ") + DataDefValue v -> text ("value" ++ show v ++ " ") _ -> empty) <.> (case datakind of Inductive -> keyword env "type" @@ -259,7 +259,8 @@ prettyDataInfo env0 showBody publicOnly isExtend info@(DataInfo datakind name ki indent 2 (vcat (map (prettyConInfo env publicOnly) cons)) <-> text "}") else empty)) -prettyConInfo env0 publicOnly (ConInfo conName ntname foralls exists fields scheme sort range paramRanges paramVis singleton vis doc) +prettyConInfo env0 publicOnly (ConInfo conName ntname foralls exists fields scheme sort range paramRanges paramVis singleton + orderedFields vrepr vis doc) = if (publicOnly && isPrivate vis) then empty else (prettyComment env0 doc $ (if publicOnly then empty else ppVis env0 vis) <.> @@ -268,7 +269,8 @@ prettyConInfo env0 publicOnly (ConInfo conName ntname foralls exists fields sche (if null exists then empty else (angled (map (ppTypeVar env) exists))) <.> (if null fields then empty - else parens (commaSep (map (ppField env) (zip paramVis fields)))) + else parens (commaSep (map (ppField env) (zip paramVis fields)))) <.> + (text (show vrepr)) <+> text ":" <+> ppType env scheme <.> semi) where ppField env (fvis,(name,tp)) diff --git a/src/Type/Type.hs b/src/Type/Type.hs index ab3d6bb5d..39a65c976 100644 --- a/src/Type/Type.hs +++ b/src/Type/Type.hs @@ -1,4 +1,3 @@ ------------------------------------------------------------------------------ -- Copyright 2012-2021, Microsoft Research, Daan Leijen. -- -- This is free software; you can redistribute it and/or modify it under the @@ -14,6 +13,7 @@ module Type.Type (-- * Types , Flavour(..) , DataInfo(..), DataKind(..), ConInfo(..), SynInfo(..) , dataInfoIsRec, dataInfoIsOpen, dataInfoIsLiteral + , conInfoSize, conInfoScanCount -- Predicates , splitPredType, shallowSplitPreds, shallowSplitVars , predType @@ -40,9 +40,9 @@ module Type.Type (-- * Types , orderEffect, labelName, labelNameFull, labelNameEx , isEffectEmpty, isEffectFixed, shallowEffectExtend, shallowExtractEffectExtend - , typeDivergent, typeTotal, typePartial + , typeDivergent, typeTotal, typePartial, typePure , typeList, typeVector, typeApp, typeRef, typeNull, typeOptional, typeMakeTuple - , typeCTail, typeCField + , typeCCtx, typeCCtxx, typeFieldAddr , isOptional, makeOptional, unOptional , typeReuse, typeLocal @@ -78,7 +78,7 @@ import Common.NamePrim import Common.Range import Common.Id import Common.Failure -import Common.Syntax( Visibility, DataKind(..), DataDef(..), dataDefIsRec, dataDefIsOpen ) +import Common.Syntax( Visibility, DataKind(..), DataDef(..), ValueRepr(..), dataDefIsRec, dataDefIsOpen, valueReprSize, Platform ) import Kind.Kind {-------------------------------------------------------------------------- @@ -202,6 +202,8 @@ data ConInfo = ConInfo{ conInfoName :: Name , conInfoParamRanges :: [Range] , conInfoParamVis :: [Visibility] , conInfoSingleton :: Bool -- ^ is this the only constructor of this type? + , conInfoOrderedParams :: [(Name,Type)] -- ^ fields ordered by size + , conInfoValueRepr :: ValueRepr , conInfoVis :: Visibility , conInfoDoc :: String } @@ -210,6 +212,15 @@ instance Show ConInfo where show info = show (conInfoName info) +-- return size and scan count for a constructor +conInfoSize :: Platform -> ConInfo -> Int +conInfoSize platform conInfo + = valueReprSize platform (conInfoValueRepr conInfo) + +conInfoScanCount :: ConInfo -> Int +conInfoScanCount conInfo + = valueReprScanCount (conInfoValueRepr conInfo) + -- | A type synonym is quantified by type parameters data SynInfo = SynInfo{ synInfoName :: Name , synInfoKind :: Kind @@ -223,6 +234,8 @@ data SynInfo = SynInfo{ synInfoName :: Name deriving Show + + {-------------------------------------------------------------------------- Accessors --------------------------------------------------------------------------} @@ -514,7 +527,7 @@ typeResumeContext :: Tau -> Effect -> Effect -> Tau -> Tau typeResumeContext b e e0 r = TApp (TCon tcon) [b,e,e0,r] where - tcon = TypeCon nameTpResumeContext (kindFun kindStar (kindFun kindEffect (kindFun kindEffect kindStar))) + tcon = TypeCon nameTpResumeContext (kindFun kindStar (kindFun kindEffect (kindFun kindEffect (kindFun kindStar kindStar)))) typeRef :: Tau typeRef @@ -765,22 +778,30 @@ isTypeUnit _ = False -- | Type of ctail -typeCTail :: Tau -typeCTail - = TCon tconCTail +typeCCtx :: Tau -> Tau +typeCCtx tp + = TSyn tsynCCtx [tp] (TApp typeCCtxx [tp,tp]) + +tsynCCtx :: TypeSyn +tsynCCtx + = TypeSyn nameTpCCtx (kindFun kindStar kindStar) 0 Nothing + +typeCCtxx :: Tau +typeCCtxx + = TCon tconCCtxx -tconCTail :: TypeCon -tconCTail - = TypeCon nameTpCTailAcc (kindFun kindStar kindStar) +tconCCtxx :: TypeCon +tconCCtxx + = TypeCon nameTpCCtxx (kindFun kindStar (kindFun kindStar kindStar)) -- | Type of cfield -typeCField :: Tau -typeCField - = TCon tconCField +typeFieldAddr :: Tau +typeFieldAddr + = TCon tconFieldAddr -tconCField :: TypeCon -tconCField - = TypeCon nameTpCField (kindFun kindStar kindStar) +tconFieldAddr :: TypeCon +tconFieldAddr + = TypeCon nameTpFieldAddr (kindFun kindStar kindStar) -- | Type of vectors (@[]@) typeVector :: Tau diff --git a/src/Type/TypeVar.hs b/src/Type/TypeVar.hs index bd2cf0a90..cd822f949 100644 --- a/src/Type/TypeVar.hs +++ b/src/Type/TypeVar.hs @@ -114,7 +114,7 @@ subNew sub -- assertion "Type.TypeVar.subNew.Tau" (all isTau taus) $ let s = assertion ("Type.TypeVar.subNew.KindMismatch: length " ++ show (length sub) ++ ": " ++ unlines (map (\(x,t) -> "(" ++ showTypeVar x ++ " |-> " ++ showTp t ++ ")") sub)) - (all (\(x, t) -> getKind x == getKind t) sub) $ + (all (\(x, t) -> getKind x == getKind t) sub) $ Sub (M.fromList sub) in seq s s diff --git a/src/Type/Unify.hs b/src/Type/Unify.hs index 64d9a5b44..f6a19f24c 100644 --- a/src/Type/Unify.hs +++ b/src/Type/Unify.hs @@ -501,11 +501,11 @@ instance Functor Unify where Err err st2 -> Err err st2) instance Applicative Unify where - pure = return - (<*>) = ap + pure x = Unify (\st -> Ok x st) + (<*>) = ap instance Monad Unify where - return x = Unify (\st -> Ok x st) + -- return = pure (Unify u) >>= f = Unify (\st1 -> case u st1 of Ok x st2 -> case f x of Unify u2 -> u2 st2 diff --git a/stack.yaml b/stack.yaml index 991492511..fe324a229 100644 --- a/stack.yaml +++ b/stack.yaml @@ -13,7 +13,9 @@ # $ cabal new-run koka # See also . -resolver: lts-18.21 # ghc 8.10.7 -- works for M1 +resolver: lts-21.0 # ghc 9.4.5 +# resolver: lts-19.7 # ghc 9.0.2 +# resolver: lts-18.28 # ghc 8.10.7 -- works for M1 # resolver: lts-18.6 # ghc 8.10.4 # resolver: lts-14.27 # ghc 8.6.5 # resolver: lts-9.21 # ghc 8.0.2 -- works for older linux-arm64 @@ -23,8 +25,8 @@ packages: - '.' extra-deps: -- regex-compat-tdfa-0.95.1.4 # only needed for koka-test -- json-0.10 # only needed for koka-test +- regex-compat-0.95.2.1 # only needed for koka-test (use 0.95.1.4 for pre lts-21.0) +- json-0.10 # only needed for koka-test - isocline-1.0.7 rebuild-ghc-options: true diff --git a/support/vscode/koka.language-koka/package.json b/support/vscode/koka.language-koka/package.json index e8e3f2e53..38f9d28e3 100644 --- a/support/vscode/koka.language-koka/package.json +++ b/support/vscode/koka.language-koka/package.json @@ -2,7 +2,7 @@ "name": "language-koka", "displayName": "Koka Syntax Highlighting", "description": "Official syntax support for the Koka programming language.", - "version": "2.0.4", + "version": "2.0.5", "publisher": "koka", "engines": { "vscode": "^1.0.0" diff --git a/support/vscode/koka.language-koka/syntaxes/koka.json b/support/vscode/koka.language-koka/syntaxes/koka.json index a534b6c5d..53a719f2e 100644 --- a/support/vscode/koka.language-koka/syntaxes/koka.json +++ b/support/vscode/koka.language-koka/syntaxes/koka.json @@ -305,7 +305,7 @@ }, "reservedid" : - { "match": "(return(?=(?:\\(|\\s+\\(?)\\w[\\w\\-]*\\s*(?:\\)\\s*(?:[^;])))|infix|infixr|infixl|type|co|rec|struct|alias|forall|exists|some|extern|fun|fn|val|var|con|with(?:\\s+override)?|module|import|as|in|pub|abstract|effect|named|(?:raw\\s+|final\\s+)ctl|break|continue|unsafe|mask(?:\\s+behind)?|handle|handler)(?![\\w\\-?'])" + { "match": "(return(?=(?:\\(|\\s+\\(?)\\w[\\w\\-]*\\s*(?:\\)\\s*(?:[^;])))|infix|infixr|infixl|type|co|rec|struct|alias|forall|exists|some|extern|fun|fn|val|var|con|with(?:\\s+override)?|module|import|as|in|ctx|hole|pub|abstract|effect|named|(?:raw\\s+|final\\s+)ctl|break|continue|unsafe|mask(?:\\s+behind)?|handle|handler)(?![\\w\\-?'])" , "name": "keyword.other koka.keyword" }, @@ -423,7 +423,7 @@ }, "decl_function": - { "match": "((?:inline|noinline)?\\s*(?:fun|fn|ctl|ret))\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\)|\\[\\]|\\\"[^\\s\\\"]+\\\")" + { "match": "((?:(?:inline|noinline)\\s+)?(?:tail\\s+)?(?:(?:fip|fbip)(?:\\(\\d+\\))?\\s+)?(?:fun|fn|ctl|ret))\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\)|\\[\\]|\\\"[^\\s\\\"]+\\\")" , "captures": { "1": { "name": "keyword.declaration.function koka.keyword.fun" }, "2": { "name": "entity.name.function koka.id.decl.function" } @@ -444,7 +444,7 @@ }, "decl_external": - { "match": "((?:inline|noinline)?\\s*extern)\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\)|\\[\\]|\\\"[^\\s\\\"]+\\\")?" + { "match": "((?:(?:inline|noinline)\\s+)?(?:(?:fip|fbip)\\s+)?extern)\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\)|\\[\\]|\\\"[^\\s\\\"]+\\\")?" , "captures": { "1": { "name": "keyword.declaration.function koka.keyword.extern" }, "2": { "name": "entity.name.function koka.id.decl.function" } @@ -452,7 +452,7 @@ }, "decl_val": - { "match": "((?:inline|noinline)?\\s*val)\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\))?" + { "match": "((?:(?:inline|noinline)\\s+)?val)\\s+([\\.a-z][\\w\\-]*[\\'\\?]*(?:\\.\\d+)?|\\([$%&\\*\\+@!/\\\\\\^~=\\.:\\-\\?\\|<>]+(?:\\.\\d+)?\\))?" , "captures": { "1": { "name": "keyword.declaration koka.keyword.val" }, "2": { "name": "entity.name koka.id.decl.val" } @@ -474,7 +474,7 @@ "top_type": { "begin": "(:(?![$%&\\*\\+@!\\\\\\^~=\\.:\\-\\|<>]))|(where|iff|when)(?![\\w\\-])" - , "end": "(?=[,\\)\\{\\}\\[\\]=;\"`A-Z]| |(infix|infixr|infixl|inline|noinline|value|reference|open|extend|rec|co|type|linear|effect|context|ambient|alias|extern|fn|fun|function|val|raw|final|ctl|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" + , "end": "(?=[,\\)\\{\\}\\[\\]=;\"`A-Z]| |(infix|infixr|infixl|inline|noinline|fip|fbip|tail|value|ref|open|extend|rec|co|type|linear|effect|context|ambient|alias|extern|fn|fun|function|val|raw|final|ctl|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "constant.numeric.type support.type koka.type" }, "2" : { "name": "keyword koka.keyword.$2" } } , "endCaptures": { "0" : { "name": "invalid.keyword koka.invalid" }} @@ -485,8 +485,8 @@ "top_type_type": - { "begin": "((?:(?:value|reference|open|extend|rec|co)?\\s*type)|(?:named\\s+)?(?:scoped\\s+)?(?:linear\\s+)?(?:rec\\s+)?(?:effect|context|ambient))\\s+(?!fn|fun|val|raw|final|ctl|ret)([a-z][\\w\\-]+|<>|<\\|>|\\(,*\\))" - , "end": "(?=[\\)\\{\\}\\[\\]=;\"`A-Z]| [\\r\\n]|(infix|infixr|infixl|inline|noinline|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|raw|final|ctl|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract|value|reference|open|extend|inline|noinline)(?![\\w\\-?']))" + { "begin": "((?:(?:value|ref|open|extend|rec|co)?\\s*type)|(?:named\\s+)?(?:scoped\\s+)?(?:linear\\s+)?(?:rec\\s+)?(?:effect|context|ambient))\\s+(?!fn|fun|val|raw|final|ctl|ret)([a-z][\\w\\-]+|<>|<\\|>|\\(,*\\))" + , "end": "(?=[\\)\\{\\}\\[\\]=;\"`A-Z]| [\\r\\n]|(infix|infixr|infixl|inline|noinline|fip|fbip|tail|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|raw|final|ctl|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract|value|ref|open|extend)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "keyword.declaration.type koka.keyword" } , "2" : { "name": "constant.numeric.type support.type koka.type.typecon" }} , "endCaptures": { "0": { "name": "punctuation.separator koka.special" }} @@ -497,7 +497,7 @@ "top_type_alias": { "begin": "(alias)\\s+([a-z][\\w\\-]+)" - , "end": "(?=[,\\)\\{\\}\\[\\];\"`A-Z]|(infix|infixr|infixl|inline|noinline|type|co|rec|linear|alias|effect|context|ambient|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" + , "end": "(?=[,\\)\\{\\}\\[\\];\"`A-Z]|(infix|infixr|infixl|inline|noinline|fip|fbip|tail|type|co|rec|linear|alias|effect|context|ambient|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "keyword.declaration koka.keyword" } , "2" : { "name": "constant.numeric.type support.type koka.type.typecon" }} , "endCaptures": { "0": { "name": "invalid.keyword koka.keyword.invalid" }} @@ -511,7 +511,7 @@ }, "top_type_struct": - { "match": "(struct)\\s+([a-z][\\w\\-]*|\\(,*\\))" + { "match": "((?:(?:value|ref)\\s*)?struct)\\s+([a-z][\\w\\-]*|\\(,*\\))" , "captures": { "1": { "name": "keyword.declaration koka.keyword.struct" }, "2": { "name": "constant.numeric.type support.type koka.type.typecon" } @@ -519,8 +519,8 @@ }, "top_type_struct_args": - { "begin": "(struct)\\s+([a-z][\\w\\-]*|\\(,*\\))\\s*(<)" - , "end": "(>)|(?=[\\)\\{\\}\\[\\]=;\"`]|(infix|infixr|infixl|inline|noinline|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" + { "begin": "((?:(?:value|ref)\\s*)?struct)\\s+([a-z][\\w\\-]*|\\(,*\\))\\s*(<)" + , "end": "(>)|(?=[\\)\\{\\}\\[\\]=;\"`]|(infix|infixr|infixl|inline|noinline|fip|fbip|tail|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "keyword.declaration koka.keyword.struct" }, "2" : { "name": "constant.numeric.type support.type koka.type.typecon" }, "3" : { "name": "constant.numeric.type support.type koka.type.special" }} @@ -533,7 +533,7 @@ "top_type_quantifier": { "begin": "(exists|forall|some)(\\s*)(<)" - , "end": "(>)|(?=[\\)\\{\\}\\[\\]=;\"`]|(infix|infixr|infixl|inline|noinline|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" + , "end": "(>)|(?=[\\)\\{\\}\\[\\]=;\"`]|(infix|infixr|infixl|inline|noinline|fip|fbip|tail|type|co|rec|effect|context|ambient|alias|extern|fn|fun|function|val|var|con|if|then|else|elif|match|inject|mask|named|handle|handler|return|module|import|as|pub|abstract)(?![\\w\\-?']))" , "beginCaptures": { "1" : { "name": "keyword koka.keyword" }, "3" : { "name": "constant.numeric.type support.type koka.type.special" }} , "endCaptures": { "1": {"name": "constant.numeric.type support.type koka.type.special" }, diff --git a/test/Spec.hs b/test/Spec.hs index 95c26d36a..1997e933b 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -26,9 +26,9 @@ data Mode = Test | New | Update deriving (Eq, Ord, Show) -data Options = Options{ mode :: Mode, cabal :: Bool, sysghc:: Bool, opt :: Int, js :: Bool, par :: Bool } +data Options = Options{ mode :: Mode, cabal :: Bool, sysghc:: Bool, opt :: Int, target :: String, par :: Bool } -optionsDefault = Options Test False False 0 False True +optionsDefault = Options Test False False 0 "" True data Cfg = Cfg{ flags :: [String], options :: Options, @@ -71,7 +71,7 @@ extendCfg (Cfg flags1 opts1 exclude1 fexclude1) (Cfg flags2 opts2 exclude2 fexcl initialCfg :: Options -> Cfg initialCfg options - = makeCfg (commonFlags ++ if (js options) then ["--target=js"] else []) + = makeCfg (commonFlags ++ if (not (null (target options))) then ["--target=" ++ target options] else []) options [] @@ -93,7 +93,9 @@ testSanitize kokaDir . sub "\\\\" "/" -- type variable names and box names . sub "\\.box-x[[:digit:]]+(-x[[:digit:]]+)?" ".box" + . sub "(\\.[a-zA-Z])[[:digit:]]+" "\\1" . sub "([a-zA-Z])\\.[[:digit:]]+" "\\1" + -- . sub "([a-zA-Z])\\.[[:digit:]]+\\.[[:digit:]]+" "\\1" . sub "<[[:digit:]]+>" "<0>" -- for tests using --showhiddentypesigs, -- e.g. .lift250-main => .lift000-main @@ -117,7 +119,7 @@ runKoka cfg kokaDir fp = do caseFlags <- readFlagsFile (fp ++ ".flags") let relTest = makeRelative kokaDir fp optFlag = if (opt (options cfg) /= 0) then ["-O" ++ show (opt (options cfg))] else [] - kokaFlags = flags cfg ++ optFlag ++ caseFlags + kokaFlags = optFlag ++ flags cfg ++ caseFlags if (cabal (options cfg)) then do let argv = ["new-run", "koka", "--"] ++ kokaFlags ++ [relTest] testSanitize kokaDir <$> readProcess "cabal" argv "" @@ -189,7 +191,9 @@ processOptions arg (options,hargs) else if (arg == "--system-ghc") then (options{sysghc=True}, hargs) else if (arg == "--target-js") - then (options{js=True}, hargs) + then (options{target="js"}, hargs) + else if (arg == "--target-c64c") + then (options{target="c64c"}, hargs) else if (arg == "--seq") then (options{par=False}, hargs) else (options, arg : hargs) @@ -218,7 +222,7 @@ main = do let cfg = initialCfg options runKoka cfg "" "util/link-test.kk" putStrLn "ok." - let spec = (if (js options || not (par options)) then id else parallel) $ + let spec = (if (target options == "js" || not (par options)) then id else parallel) $ discoverTests cfg (pwd "test") summary <- withArgs [] (runSpec spec hcfg{configFormatter=Just specProgress}) evaluateSummary summary diff --git a/test/algeff/perf1c.kk b/test/algeff/perf1c.kk index 9810428b9..ea5a0ae0c 100644 --- a/test/algeff/perf1c.kk +++ b/test/algeff/perf1c.kk @@ -1,43 +1,34 @@ import std/time/timer -effect state { +effect state fun get() : s fun put(i : s) : () -} -fun fib(n) { - if (n<=1) then 1 else fib(n - 1) + fib(n - 2); -} +fun fib(n) + if (n<=1) then 1 else fib(n - 1) + fib(n - 2) -fun comp() { +fun comp() fib(4) -} -fun count() { - comp(); +fun count() + comp() val i = get() - if (i == 0) then i else { + if (i == 0) then i else put(i - 1) count() - } -} - -fun test-normal(i0,action) { +fun test-normal(i0,action) var i := i0 - handle({mask(action)}) { - fun get() { i } - fun put(j) { i := j; () } - } -} + with handler + fun get() i + fun put(j) i := j + action() -fun test-direct(i) { - comp(); +fun test-direct(i) + comp() if (i==0) then i else test-direct(i - 1) -} -val n = 1000000 -fun main() { +val n = 10000000 +fun main() print-elapsed({test-direct(n)}, "direct") print-elapsed({test-normal(n,count)},"handler") -} diff --git a/test/algeff/perf2.kk b/test/algeff/perf2.kk index abc4b7187..6dd53230b 100644 --- a/test/algeff/perf2.kk +++ b/test/algeff/perf2.kk @@ -81,6 +81,8 @@ fun queens-choose(n : int ) : div solutions { fun test(n) { print-elapsed({ queens(n) }, "regular").length.println print-elapsed({ queens-choose(n) }, "algebraic").length.println + //queens(n).length.println + //queens-choose(n).length.println } fun main() { diff --git a/test/bench/Dockerfile b/test/bench/Dockerfile index d5b3e8455..ec8eb155d 100644 --- a/test/bench/Dockerfile +++ b/test/bench/Dockerfile @@ -13,37 +13,62 @@ RUN apt-get install -y --no-install-recommends ca-certificates RUN apt-get install -y --no-install-recommends cmake make RUN apt-get install -y --no-install-recommends git RUN apt-get install -y --no-install-recommends gcc libc-dev -RUN apt-get install -y --no-install-recommends ghc ocaml -RUN apt-get install -y --no-install-recommends ghc ocaml RUN apt-get install -y --no-install-recommends curl xz-utils gnupg netbase zlib1g-dev RUN apt-get install -y --no-install-recommends build-essential tar RUN rm -rf /var/lib/apt/lists/* + +# Swift WORKDIR /build -RUN curl -sSL https://get.haskellstack.org/ | sh -RUN git clone --recursive https://github.com/koka-lang/koka -b v2.1.1 -WORKDIR /build/koka -RUN stack build -RUN stack exec koka -- util/bundle -- --postfix=docker -RUN util/install.sh -f -b bundle/koka-docker.tar.gz -WORKDIR /build -RUN curl -O https://swift.org/builds/swift-5.3.3-release/ubuntu2004/swift-5.3.3-RELEASE/swift-5.3.3-RELEASE-ubuntu20.04.tar.gz -RUN tar -xzf swift-5.3.3-RELEASE-ubuntu20.04.tar.gz -WORKDIR /build/swift-5.3.3-RELEASE-ubuntu20.04/usr +RUN curl -O https://download.swift.org/swift-5.6.1-release/ubuntu2004/swift-5.6.1-RELEASE/swift-5.6.1-RELEASE-ubuntu20.04.tar.gz +RUN tar -xzf swift-5.6.1-RELEASE-ubuntu20.04.tar.gz +WORKDIR /build/swift-5.6.1-RELEASE-ubuntu20.04/usr RUN mkdir /opt/swift RUN cp -r * /opt/swift + +# Java WORKDIR /build RUN apt-get update RUN apt-get install -y --no-install-recommends software-properties-common RUN add-apt-repository ppa:linuxuprising/java -RUN echo debconf shared/accepted-oracle-license-v1-2 select true | debconf-set-selections -RUN echo debconf shared/accepted-oracle-license-v1-2 seen true | debconf-set-selections -RUN apt-get install -y --no-install-recommends oracle-java15-installer -RUN apt-get install -y --no-install-recommends oracle-java15-set-default +RUN echo debconf shared/accepted-oracle-license-v1-3 select true | debconf-set-selections +RUN echo debconf shared/accepted-oracle-license-v1-3 seen true | debconf-set-selections +RUN apt-get install -y --no-install-recommends oracle-java17-installer +RUN apt-get install -y --no-install-recommends oracle-java17-set-default RUN apt-get install -y --no-install-recommends libedit2 libz3-dev RUN apt-get install -y --no-install-recommends time + +# Haskell +WORKDIR /build +RUN apt-get install -y --no-install-recommends ghc cabal-install +RUN cabal update +RUN cabal install parallel + +# OCaml (multicore) +WORKDIR /build +RUN apt-get install -y --no-install-recommends opam +RUN opam init -y --disable-sandboxing +RUN opam update -y +RUN opam switch -y create 4.14.0 --repositories=multicore=git+https://github.com/ocaml-multicore/multicore-opam.git,default + +# Stack +WORKDIR /build +RUN curl -sSL https://get.haskellstack.org/ | sh +RUN git clone --recursive https://github.com/koka-lang/koka -b v2.4.1-artifact + +# Koka +WORKDIR /build/koka +RUN stack build +RUN apt-get install -y --no-install-recommends pcre2-utils +RUN stack exec koka -- -e util/bundle -- --postfix=docker +RUN util/install.sh -f -b bundle/v2.4.1/koka-docker.tar.gz + +# Benchmarks WORKDIR /build/koka/test/bench RUN mkdir build WORKDIR /build/koka/test/bench/build RUN cmake .. -DCMAKE_BUILD_TYPE=Release -RUN cmake --build . -RUN echo "ulimit -s unlimited" >> ~/.bashrc \ No newline at end of file + +SHELL ["/bin/bash", "-c"] +RUN eval $(opam env) && cmake --build . +RUN echo "ulimit -s unlimited" >> ~/.bashrc +RUN opam env >> ~/.bashrc diff --git a/test/bench/bench.kk b/test/bench/bench.kk index 16affbae6..67ac1ef29 100644 --- a/test/bench/bench.kk +++ b/test/bench/bench.kk @@ -6,7 +6,7 @@ // Benchmark script // ---------------------------------------------------- -import std/num/double +import std/num/float64 import std/os/file import std/os/path import std/os/env @@ -66,7 +66,7 @@ fun flag-usage() { ].unlines) } -public fun process-flags() : maybe { +pub fun process-flags() : maybe { val (flags,args,errs) = parse( Iflags(), flag-descs, get-args() ) if (flags.help) then { flag-usage() @@ -90,17 +90,17 @@ public fun process-flags() : maybe { struct test { name: string lang: string - elapsed: double = 0.0 - elapsed-sdev : double = 0.0 + elapsed: float64 = 0.0 + elapsed-sdev : float64 = 0.0 rss: int = 0 err: string = "" - norm-elapsed: double = 0.0 - norm-rss: double = 0.0 - norm-elapsed-sdev : double = 0.0 + norm-elapsed: float64 = 0.0 + norm-rss: float64 = 0.0 + norm-elapsed-sdev : float64 = 0.0 } -fun rss-double(t : test) : double { - t.rss.double +fun rss-float64(t : test) : float64 { + t.rss.float64 } fun show( test : test ) { @@ -122,7 +122,7 @@ fun show-norm( test : test ) { // ---------------------------------------------------- // main // ---------------------------------------------------- -public fun main() +pub fun main() match (process-flags()) Nothing -> () Just(flags) -> @@ -167,7 +167,7 @@ fun run-tests(test-names : list, lang-names : list<(string,string)>, gen val ntests = tests.map fn(t) { val norm = if (koka.elapsed==0.0) then 1.0 else t.elapsed / koka.elapsed t(norm-elapsed = norm, - norm-rss = if (koka.rss==0) then 1.0 else t.rss.double / koka.rss.double, + norm-rss = if (koka.rss==0) then 1.0 else t.rss.float64 / koka.rss.float64, norm-elapsed-sdev = norm * t.elapsed-sdev) } println("\n--- normalized " ++ test-name ++ " ----------------") @@ -184,13 +184,13 @@ fun run-tests(test-names : list, lang-names : list<(string,string)>, gen // emit latex chart if (gen-chart) then { val ymax = 3.0 - val chart-desc = @"16-core AMD 5950X at 3.4Ghz\\Ubuntu 20.04, gcc 9.3.0" + val chart-desc = r"16-core AMD 5950X at 3.4Ghz\\Ubuntu 20.04, gcc 9.3.0" val chart-elapsed = if (normalize) then chart("time", True, norm-elapsed, norm-elapsed-sdev, elapsed, test-names, lang-ntests, ymax, chart-desc) else chart("time", False, elapsed, elapsed-sdev, elapsed, test-names, lang-ntests, ymax, chart-desc) val chart-rss = if (True || normalize) - then chart("rss", True, norm-rss, fn(t){ 0.0 }, rss-double, test-names, lang-ntests, ymax, chart-desc) - else chart("rss", False, rss-double, fn(t){ 0.0 }, rss-double, test-names, lang-ntests, ymax, chart-desc) + then chart("rss", True, norm-rss, fn(t){ 0.0 }, rss-float64, test-names, lang-ntests, ymax, chart-desc) + else chart("rss", False, rss-float64, fn(t){ 0.0 }, rss-float64, test-names, lang-ntests, ymax, chart-desc) println("\n") println(chart-elapsed) println("\n") @@ -203,7 +203,7 @@ fun run-tests(test-names : list, lang-names : list<(string,string)>, gen // ---------------------------------------------------- // Latex chart // ---------------------------------------------------- -fun chart( kind : string, normalize : bool, norm : test -> double, norm-sdev : test -> double, abs : test -> double, test-names : list, lang-ntests : list<(string,list)>, ymax : double = 2.0, desc : string = "" ) : string { +fun chart( kind : string, normalize : bool, norm : test -> float64, norm-sdev : test -> float64, abs : test -> float64, test-names : list, lang-ntests : list<(string,list)>, ymax : float64 = 2.0, desc : string = "" ) : string { [ tikz-header(test-names,".bench" ++ kind) , lang-ntests.flatmap(fn(l){ tikz-data(kind, normalize, norm, norm-sdev, abs, l, ymax = ymax ) }) , tikz-picture(kind, normalize, test-names, lang-ntests.map(fst), ymax = ymax, desc = desc ) @@ -222,32 +222,32 @@ fun tikz-footer( test-names : list ) : list { [ "~ End Snippet" ] } -fun tikz-picture( kind : string, normalize : bool, test-names : list, lang-names : list, ymax : double = 5.0, +fun tikz-picture( kind : string, normalize : bool, test-names : list, lang-names : list, ymax : float64 = 5.0, desc : string = "", height:string = "5cm", width:string = "6cm" ) { val n = test-names.length - 1 val header = [ - @"", - @"\begin{tikzpicture}\sffamily", - @"\begin{axis}[Chart" ++ (if (normalize) then "norm" else "abs") ++ kind ++ ",ymax=" ++ ymax.show(1) ++ ",height=" ++ height ++ ",xmax=" ++ n.show ++ ".5,width=" ++ width ++ "]", - if (normalize) then @" \draw (axis cs:-0.5,1) -- (axis cs:" ++ n.show ++ ".5,1);" else "" + r"", + r"\begin{tikzpicture}\sffamily", + r"\begin{axis}[Chart" ++ (if (normalize) then "norm" else "abs") ++ kind ++ ",ymax=" ++ ymax.show(1) ++ ",height=" ++ height ++ ",xmax=" ++ n.show ++ ".5,width=" ++ width ++ "]", + if (normalize) then r" \draw (axis cs:-0.5,1) -- (axis cs:" ++ n.show ++ ".5,1);" else "" ] - val mid = lang-names.map(fn(l){ @" \draw" ++ kind ++ @"{color" ++ l ++ @"}{\data" ++ kind ++ l ++ "};"}) + val mid = lang-names.map(fn(l){ r" \draw" ++ kind ++ r"{color" ++ l ++ r"}{\data" ++ kind ++ l ++ "};"}) val footer = [ - if (kind=="time") then @" \legend{" ++ lang-names.map(fn(l){ "\\lang" ++ l }).join(",") ++ "};" + if (kind=="time") then r" \legend{" ++ lang-names.map(fn(l){ "\\lang" ++ l }).join(",") ++ "};" else "", - // if (desc.is-empty) then "" else @" \chartdesc{" ++ desc.replace-all("\n",@"\\") ++ "};", - @"\end{axis}", - @"\end{tikzpicture}" + // if (desc.is-empty) then "" else r" \chartdesc{" ++ desc.replace-all("\n",r"\\") ++ "};", + r"\end{axis}", + r"\end{tikzpicture}" ] (header ++ mid ++ footer) } -fun tikz-data( kind:string, normalize : bool, norm : test -> double, norm-sdev : test -> double, abs : test -> double, lang-ntests : (string,list), ymax : double = 5.0 ) : list { +fun tikz-data( kind:string, normalize : bool, norm : test -> float64, norm-sdev : test -> float64, abs : test -> float64, lang-ntests : (string,list), ymax : float64 = 5.0 ) : list { val (lang,ntests) = lang-ntests ["", - @"\pgfplotstableread{", - @"x y y-error meta"] ++ + r"\pgfplotstableread{", + r"x y y-error meta"] ++ ntests.map-indexed(fn(i:int,t:test){ val tval = if (normalize) then t.norm else t.abs if (t.err.is-empty) then { @@ -258,39 +258,39 @@ fun tikz-data( kind:string, normalize : bool, norm : test -> double, norm-sdev : then (if (normalize) then ( if (lang == "kk") then (if (kind=="rss") - then @"{\absrssnormlabel{" ++ (t.abs / 1024.0).round.int.show ++ "mb}}" // megabytes - else @"{\absnormlabel{" ++ t.abs.show-fixed(2) ++ "}}" ) - else @"{\normlabel{" ++ t.norm.show-fixed(2) ++ "}}" ) - else @"{\abslabel{" ++ t.abs.show-fixed(2) ++ "}}") + then r"{\absrssnormlabel{" ++ (t.abs / 1024.0).round.int.show ++ "mb}}" // megabytes + else r"{\absnormlabel{" ++ t.abs.show-fixed(2) ++ "}}" ) + else r"{\normlabel{" ++ t.norm.show-fixed(2) ++ "}}" ) + else r"{\abslabel{" ++ t.abs.show-fixed(2) ++ "}}") else (if (normalize) - then (@"{\outernormlabel{" ++ t.norm.show(2) ++ "}}") - else (@"{\outerlabel{" ++ t.abs.show(2) ++ "}}")) + then (r"{\outernormlabel{" ++ t.norm.show(2) ++ "}}") + else (r"{\outerlabel{" ++ t.abs.show(2) ++ "}}")) ].join(" ") } - else "" // ("" ++ i.show ++ @" 0.100 0.000 " ++ (if (i==0) then "0" elif (t.err=="NA") then "{NA}" else @"{\ensuremath{\times}}")) + else "" // ("" ++ i.show ++ r" 0.100 0.000 " ++ (if (i==0) then "0" elif (t.err=="NA") then "{NA}" else r"{\ensuremath{\times}}")) }) ++ - [@"}\data" ++ kind ++ lang] + [r"}\data" ++ kind ++ lang] } // ---------------------------------------------------- // Run a single test // ---------------------------------------------------- -fun insert(xs:list, y :double) : list { +fun insert(xs:list, y :float64) : list { match(xs) { Cons(x,xx) | y > x -> Cons(x,xx.insert(y)) _ -> Cons(y,xs) } } -fun sort(xs : list ) : list { +fun sort(xs : list ) : list { match(xs) { Cons(x,xx) -> xx.sort.insert(x) Nil -> Nil } } -fun median( xs : list ) : double { +fun median( xs : list ) : float64 { val n = xs.length val ys = xs.sort match(ys.drop(n/2 - 1)) { @@ -341,8 +341,8 @@ fun run-test( test-name : string, langt : (string,string), iterations : int ) : } val melapsed = results.map(elapsed).median - val mrss = results.map(fn(t){ t.rss.double }).median.int - val sdev = sqrt( results.map( fn(t){ sqr(t.elapsed - melapsed) } ).sum / results.length.double ) + val mrss = results.map(fn(t){ t.rss.float64 }).median.int + val sdev = sqrt( results.map( fn(t){ sqr(t.elapsed - melapsed) } ).sum / results.length.float64 ) // println("melapsed: " ++ melapsed.show ++ ", mrss: " ++ mrss.show ++ "k") Test(test-name, lang, elapsed=melapsed, rss=mrss, elapsed-sdev=sdev) @@ -352,7 +352,7 @@ fun test-sum( t1 : test, t2 : test) : test { t1( elapsed = t1.elapsed + t2.elapsed, rss = t1.rss + t2.rss ) } -fun execute-test( run : int, base : string, prog : string, envvars : string ) : io either +fun execute-test( run : int, base : string, prog : string, envvars : string ) : io either val timef= "out/time-" ++ base ++ ".txt" val cmd = (if envvars.is-empty then "" else ("env " ++ envvars ++ " ")) ++ (if get-env("SHELL").default("").contains("zsh") @@ -370,13 +370,13 @@ fun execute-test( run : int, base : string, prog : string, envvars : string ) : _ -> val parts = time.replace-all("\n"," ").replace-all("\t"," ").split(" ").filter(fn(p) !p.is-empty ) // println( parts.join(",") ) - match(parts) { + match(parts) Cons(elapsed,Cons(rss,Nil)) -> // linux println("" ++ run.show ++ ": elapsed: " ++ elapsed ++ "s, rss: " ++ rss ++ "kb" ) - Right( (parse-double(elapsed).default(0.0), parse-int(rss).default(0)) ) + Right( (parse-float64(elapsed).default(0.0), parse-int(rss).default(0)) ) Cons(elapsed,Cons("real",Cons(_,Cons(_user,Cons(_,Cons(_sys,Cons(rss,_))))))) -> // on macOS println("" ++ run.show ++ ": elapsed: " ++ elapsed ++ "s, rss: " ++ rss ++ "b" ) - Right( (parse-double(elapsed).default(0.0), parse-int(rss).default(0)/1024) ) + Right( (parse-float64(elapsed).default(0.0), parse-int(rss).default(0)/1024) ) _ -> Left("bad format") diff --git a/test/bench/haskell/rbtree.hs b/test/bench/haskell/rbtree.hs index 0aa16085d..0bcf75b34 100644 --- a/test/bench/haskell/rbtree.hs +++ b/test/bench/haskell/rbtree.hs @@ -36,7 +36,7 @@ ins Leaf kx vx = Node Red Leaf kx vx Leaf ins (Node Red a ky vy b) kx vx = (if lt kx ky then Node Red (ins a kx vx) ky vy b else if lt ky kx then Node Red a ky vy (ins b kx vx) - else Node Red a ky vy (ins b kx vx)) + else Node Red a kx vx b -- Node Red a ky vy (ins b kx vx)) ins (Node Black a ky vy b) kx vx = if lt kx ky then (if is_red a then balance1 (Node Black Leaf ky vy b) (ins a kx vx) diff --git a/test/bench/intbench.sh b/test/bench/intbench.sh new file mode 100755 index 000000000..9491da650 --- /dev/null +++ b/test/bench/intbench.sh @@ -0,0 +1,245 @@ +all_variants="sofa int32 ovf tagovf xsofa reno" +all_compilers="clang gcc" +all_benches="nqueens hamming pyth tak" + +variants="sofa" +compilers="clang" +benches="" + +intopts="" +ccopts="" +benchdir="test/bench/koka/" +verbose="no" + +do_build="no" +do_run="no" +max_runs=1 + +function info { + echo $1 +} + +function warning { + echo "" + echo "warning: $1" +} + +while : ; do + # set flag and flag_arg + flag="$1" + case "$flag" in + *=*) flag_arg="${flag#*=}" + flag="${flag%=*}";; + no-*) flag_arg="0" + flag="${flag#no-}";; + none) flag_arg="0" ;; + *) flag_arg="1" ;; + esac + case "$flag_arg" in + yes|on|true) flag_arg="1";; + no|off|false) flag_arg="0";; + esac + case "$flag" in + "") break;; + + allb) benches="$all_benches";; + allc) compilers="$all_compilers";; + allv) variants="$all_variants";; + + nqueens) benches="$benches nqueens";; + hamming) benches="$benches hamming";; + pyth) benches="$benches pyth";; + tak) benches="$benches tak";; + + ovf) variants="$variants ovf";; + tagovf) variants="$variants tagovf";; + sofa) variants="$variants sofa";; + xsofa) variants="$variants xsofa";; + reno) variants="$variants reno";; + + gcc) compilers="$compilers gcc";; + gcc-11) compilers="$compilers gcc-11";; + + build) do_build="yes";; + run) do_run="yes";; + graph) do_graph="yes";; + + asm) ccopts="--ccopts=-save-temps";; + + -n) + max_runs=$flag_arg;; + + -v|--verbose) + verbose="yes";; + -h|--help|-\?|help|\?) + echo "./intbench.sh [options]" + echo "" + echo "options:" + echo " -h, --help show this help" + echo " -v, --verbose be verbose (=$verbose)" + echo "" + exit 0;; + *) warning "unknown option \"$1\"." 1>&2 + esac + shift +done + + +function set_intopts { # + case "$1" in + ovf) intopts="--ccopts=-DKK_INT_ARITHMETIC=1";; + tagovf) intopts="--ccopts=-DKK_INT_ARITHMETIC=2";; + sofa) intopts="--ccopts=-DKK_INT_ARITHMETIC=3";; + reno) intopts="--ccopts=-DKK_INT_ARITHMETIC=4";; + xsofa) intopts="--ccopts=-DKK_INT_ARITHMETIC=3 --ccopts=-DKK_INT_TAG=0";; + *) intopts="";; + esac; +} + +function build { # + local options="-O2 --cc=$3 --buildtag=$2 $ccopts" + if [ "$2" = "int32" ]; then + options="$options -c $benchdir$1.kk" + else + set_intopts "$2" + options="$options --ccopts=-DKK_INT_NOREFCOUNT $intopts -c $benchdir$1-int.kk" + fi + info "" + info "build: $1, variant: $2, cc: $3, ($options)" + stack exec koka -- $options +} + +function build_all { + for ccomp in $compilers; do + for bench in $benches; do + for variant in $variants; do + build $bench $variant $ccomp + done + done + done +} + + +function run { #bench variant cc runidx log + local bench="" + if [ "$2" = "int32" ]; then + bench="$1" + else + bench="$1_dash_int" + fi + cmd=".koka/v2.4.1-$2/$3-drelease/test_bench_koka_$bench" + info "" + info "run $4, $1-$3-$2, cmd: $cmd" + local logrun=".koka/intbench/run.txt" + $cmd --kktime 2> $logrun + cat $logrun + # extract elapsed time + local line=`head -1 $logrun` + line=${line#info: elapsed: } + local elapsed=${line/s,*/} + echo "$elapsed" >> "$5" +} + +function run_all { + for ccomp in $compilers; do + for bench in $benches; do + for variant in $variants; do + local log=".koka/intbench/$bench-$ccomp-$variant.txt" + rm -f $log 2> /dev/null + for ((runs=1; runs<=$max_runs; runs++)); do + run $bench $variant $ccomp $runs $log + done + done + done + done +} + +basetime="" + +function avg { #bench variant cc logbench + local log=".koka/intbench/$1-$3-$2.txt" + local median=`sort -n $log | awk ' { a[i++]=$1; } END { x=int((i+1)/2); if (x < (i+1)/2) print (a[x-1]+a[x])/2; else print a[x-1]; }'` + local stddev=`awk ' { sqrsum += ($1 - '"$median"')^2; } END { print sqrt(sqrsum/NR); }' < $log` + if [ "$basetime" = "" ]; then + basetime="$median" + fi + local rmedian=`echo "scale=3; $median / $basetime" | bc` + local rstddev=`echo "scale=3; $rmedian * $stddev" | bc` + echo "$1 $3 $2 ${median} ${rmedian} ${rstddev}" >> $4 +} + +function avg_all { + for bench in $benches; do + local logbench=".koka/intbench/$bench.txt" + basetime="" + rm -f $logbench 2> /dev/null + for ccomp in $compilers; do + for variant in $variants; do + avg $bench $variant $ccomp $logbench + done + done + echo "" + echo "# benchmark elapsed relat. stddev" + column -t $logbench + done +} + +function graph_variant { # + awk ' + BEGIN { + ccomp="'"$2"'" + variant="'"$1"'" + print "\\pgfplotstableread{" + print "x y y-error meta" + } + $2 == ccomp && $3 == variant { + if ($2 == "clang" && $3 == "sofa") { + printf( "%i %0.3f %0.3f {\\absnormlabel{%0.3f}}\n", i++, $5, $6, $4 ); + } + else { + printf( "%i %0.3f %0.3f {\\normlabel{%0.2f}}\n", i++, ($5>2 ? 2 : $5), $6, $5); + } + } + END { + print "}\\datatime" (ccomp=="gcc-11" ? "gcc" : ccomp) (variant=="int32"? "int" : variant) + print " " + } + ' $3 >> $4 +} + +function graph_all { + local logall=".koka/intbench/all.txt" + rm -f $logall 2> /dev/null + for bench in $benches; do + local logbench=".koka/intbench/$bench.txt" + cat $logbench >> $logall + done + local texdata=".koka/intbench/graph.tex" + echo "\\pgfplotsset{" > $texdata + echo " xticklabels = {" >> $texdata + for bench in $benches; do + echo " \\strut $bench," >> $texdata + done + echo "}}" >> $texdata + echo " " >> $texdata + for ccomp in $compilers; do + for variant in $variants; do + graph_variant $variant $ccomp $logall $texdata + done + done + cat $texdata +} + + +if [ "$do_build" = "yes" ]; then + build_all +fi + +if [ "$do_run" = "yes" ]; then + run_all + avg_all +fi + +if [ "$do_graph" = "yes" ]; then + graph_all +fi \ No newline at end of file diff --git a/test/bench/koka/CMakeLists.txt b/test/bench/koka/CMakeLists.txt index e4c551b23..4adc10b8a 100644 --- a/test/bench/koka/CMakeLists.txt +++ b/test/bench/koka/CMakeLists.txt @@ -2,7 +2,7 @@ set(sources cfold.kk deriv.kk nqueens.kk nqueens-int.kk rbtree-poly.kk rbtree.kk rbtree-int.kk rbtree-ck.kk binarytrees.kk) -find_program(kokadev "koka-v2.3.3-dev") +find_program(kokadev "koka-dev") # stack exec koka -- --target=c -O2 -c $(readlink -f ../cfold.kk) -o cfold find_program(stack "stack" REQUIRED) @@ -26,6 +26,12 @@ foreach (source IN LISTS sources) set(outx_path "${outx_dir}/${namex}") set(outdev_path "${outdev_dir}/${namedev}") + if ("${source}" MATCHES "rbtree*") + set(ccomp "clang") + else() + set(ccomp "gcc") + endfi() + add_custom_command( OUTPUT ${out_path} COMMAND ${koka} --target=c --stack=128M --outputdir=${out_dir} --buildname=${name} -v -O2 -i$ "${source}" @@ -36,11 +42,11 @@ foreach (source IN LISTS sources) add_executable(${name}-exe IMPORTED) set_target_properties(${name}-exe PROPERTIES IMPORTED_LOCATION "${out_path}") - # --fno-optctail - # --fno-optreuse + # --fno-trmc + # --fno-reuse add_custom_command( OUTPUT ${outx_path} - COMMAND ${koka} --target=c --stack=128M --outputdir=${outx_dir} --buildname=${namex} -v -O2 --fno-opttrmc -i$ "${source}" + COMMAND ${koka} --target=c --stack=128M --outputdir=${outx_dir} --buildname=${namex} -v -O2 --fno-trmc -i$ "${source}" DEPENDS ${source} VERBATIM) diff --git a/test/bench/koka/binarytrees-fbip.kk b/test/bench/koka/binarytrees-fbip.kk new file mode 100644 index 000000000..43f17116c --- /dev/null +++ b/test/bench/koka/binarytrees-fbip.kk @@ -0,0 +1,174 @@ +/* +The Computer Language Benchmarks Game +https://salsa.debian.org/benchmarksgame-team/benchmarksgame/ +*/ +module binarytrees + +import std/os/env +import std/os/task +import std/num/int32 + +type tree + Node( left : tree, right : tree ) + Tip + + +// make a perfectly balanced binary tree of `depth` using FBIP +// to use no extra stack space. +type builder + Top + BuildRight( depth : int, up : builder ) + BuildNode( left : tree, up : builder ) + +// using mutual recursion +fun make-down( depth : int, builder : builder ) : div tree + if depth > 0 + then make-down( depth - 1, BuildRight(depth - 1, builder)) + else make-up( Node(Tip,Tip), builder) + +fun make-up( t : tree, builder : builder ) : div tree + match builder + BuildRight(depth, up) -> make-down( depth, BuildNode(t, up)) + BuildNode(l, up) -> make-up( Node(l, t), up) + Top -> t + +// using a single tail recursive definition +type direction + Down( depth : int ) + Up( t : tree ) + +fun make-fbip( dir : direction, builder : builder) : div tree + match dir + Down(depth) -> if depth > 0 + then make-fbip(Down(depth - 1), BuildRight(depth - 1, builder)) + else make-fbip(Up(Node(Tip,Tip)), builder) + Up(t) -> match builder + BuildRight(depth, up) -> make-fbip(Down(depth), BuildNode(t, up)) + BuildNode(l, up) -> make-fbip(Up(Node(l, t)), up) + Top -> t + +// make a perfectly balanced binary tree of `depth` +fun make-rec( depth : int ) : div tree + if depth > 0 + then Node( make-rec(depth - 1), make-rec(depth - 1) ) + else Node( Tip, Tip ) + +type build + Root + GoRight( depth : int, up : build ) + +fun make-trmc-up( t : tree, b : build ) : div tree + match b + GoRight(depth, Root) -> + Node(t, make-trmc( depth, Root )) + GoRight(depth, up) -> + make-trmc-up( Node(t, make-trmc( depth, Root )), up ) + Root -> t + +fun make-trmc( depth : int, b : build ) : div tree + if depth > 0 + then make-trmc( depth - 1, GoRight(depth - 1, b)) + else make-trmc-up( Node(Tip,Tip), b) + +fun make-trmc-fbip( dir : direction, b : build ) : div tree + match dir + Down(depth) -> + if depth > 0 + then make-trmc-fbip( Down(depth - 1), GoRight(depth - 1, b)) + else make-trmc-fbip( Up(Node(Tip,Tip)), b) + Up(t) -> + match b + GoRight(depth, Root) -> + Node(t, make-trmc-fbip( Down(depth), Root )) + GoRight(depth, up) -> + make-trmc-fbip(Up(Node(t, make-trmc-fbip( Down(depth), Root ))), up ) + Root -> t + +fun make( depth : int ) : div tree + // make-rec(depth) + // make-trmc( depth, Root ) + // make-trmc-fbip( Down( depth), Root ) + // make-down( depth, Top ) + make-fbip(Down(depth), Top) + + + +// FBIP in action: use a visitor to run the checksum tail-recursively +type visit + Done + NodeR( right : tree, v : visit ) + +// tail-recursive checksum +fun checkv( t : tree, v : visit, acc : int ) : div int + match t + Node(l,r) -> checkv( l, NodeR(r,v), acc.inc) + Tip -> match v + NodeR(r,v') -> checkv( r, v', acc) + Done -> acc + +// normal checksum +fun checkr( t : tree ) : div int + match t + Node(l,r) -> l.checkr + r.checkr + 1 + Tip -> 0 + + +fun check( t : tree ) : div int + checkv(t, Done, 0) + //t.checkr + + + +// generate `count` trees of `depth` and return the total checksum +fun sum-count( count : int, depth : int ) : div int + fold-int(count+1,0) fn(i,csum) + // csum + make(depth).check + csum + make(depth).check + + +// parallel sum count: spawn up to `n` sub-tasks to count checksums +fun psum-count( count : int, depth : int ) : pure int + val n = 8 + val partc = count / n + val rest = count % n + val parts = list(1,n, fn(i) task{ sum-count( partc, depth ) }) + sum-count(rest, depth) + parts.await.sum + + +// for depth to max-depth with stride 2, process +// many trees of size depth in parallel and compute the total checksum +fun gen-depth( min-depth : int, max-depth : int ) : pure list<(int,int,promise)> + list(min-depth, max-depth, 2) fn(d) + val count = 2^(max-depth + min-depth - d) // todo: ensure fast 2^n operation + (count, d, task{ psum-count(count, d) }) + //(count, d, task{ sum-count(count, d) } ) // one task per depth + + +// show results +fun show( msg : string, depth : int, check : int ) : console () + println(msg ++ " of depth " ++ depth.show ++ "\t check: " ++ check.show) + + +// main +pub fun main() + // task-set-default-concurrency(8); + val n = get-args().head.default("").parse-int.default(21) + val min-depth = 4 + val max-depth = max(min-depth + 2, n) + + // allocate and free the stretch tree + val stretch-depth = max-depth.inc + show( "stretch tree", stretch-depth, make(stretch-depth).check ) + + // allocate long lived tree + // val long = make(max-depth) + val long = make(max-depth) + + // allocate and free many trees in parallel + val trees = gen-depth( min-depth, max-depth ) + trees.foreach fn((count,depth,csum)) + show( count.show ++ "\t trees", depth, csum.await ) + + // and check if the long lived tree is still good + show( "long lived tree", max-depth, long.check ) + diff --git a/test/bench/koka/binarytrees.kk b/test/bench/koka/binarytrees.kk index a710a2dcd..519d628e0 100644 --- a/test/bench/koka/binarytrees.kk +++ b/test/bench/koka/binarytrees.kk @@ -53,8 +53,41 @@ fun make-rec( depth : int ) : div tree then Node( make-rec(depth - 1), make-rec(depth - 1) ) else Node( Tip, Tip ) +type build + Root + GoRight( depth : int, up : build ) + +fun make-trmc-up( t : tree, b : build ) : div tree + match b + GoRight(depth, Root) -> + Node(t, make-trmc( depth, Root )) + GoRight(depth, up) -> + make-trmc-up( Node(t, make-trmc( depth, Root )), up ) + Root -> t + +fun make-trmc( depth : int, b : build ) : div tree + if depth > 0 + then make-trmc( depth - 1, GoRight(depth - 1, b)) + else make-trmc-up( Node(Tip,Tip), b) + +fun make-trmc-fbip( dir : direction, b : build ) : div tree + match dir + Down(depth) -> + if depth > 0 + then make-trmc-fbip( Down(depth - 1), GoRight(depth - 1, b)) + else make-trmc-fbip( Up(Node(Tip,Tip)), b) + Up(t) -> + match b + GoRight(depth, Root) -> + Node(t, make-trmc-fbip( Down(depth), Root )) + GoRight(depth, up) -> + make-trmc-fbip(Up(Node(t, make-trmc-fbip( Down(depth), Root ))), up ) + Root -> t + fun make( depth : int ) : div tree make-rec(depth) + // make-trmc( depth, Root ) + // make-trmc-fbip( Down( depth), Root ) // make-fbip(Down(depth), Top) // make-down( depth, Top ) @@ -126,11 +159,15 @@ pub fun main() // allocate and free the stretch tree val stretch-depth = max-depth.inc show( "stretch tree", stretch-depth, make(stretch-depth).check ) + // allocate long lived tree // val long = make(max-depth) val long = make(max-depth) + // test thread shared marking + // show("long lived tree in another thread", max-depth, task{ long.check }.await ) + // allocate and free many trees in parallel val trees = gen-depth( min-depth, max-depth ) trees.foreach fn((count,depth,csum)) diff --git a/test/bench/koka/cfold.kk b/test/bench/koka/cfold.kk index 78a59ddb0..2f99e1fff 100644 --- a/test/bench/koka/cfold.kk +++ b/test/bench/koka/cfold.kk @@ -59,6 +59,13 @@ fun eval(e : expr) : int Mul(l,r) -> eval(l) * eval(r) +pub fun test() : () + repeat(100) + val e = mk_expr(16,1) + val v1 = eval(e) + val v2 = e.reassoc.cfold.eval + () + pub fun main() : () val e = mk_expr(20,1) val v1 = eval(e) diff --git a/test/bench/koka/hamming-int.kk b/test/bench/koka/hamming-int.kk new file mode 100644 index 000000000..9a9d995a5 --- /dev/null +++ b/test/bench/koka/hamming-int.kk @@ -0,0 +1,17 @@ +// Euclid's gcd with subtraction +fun gcd( x : int, y : int ) : div int + if x > y + then gcd( x - y, y ) + elif x < y + then gcd( x, y - x ) + else x + +fun is-hamming( x : int ) : div bool + gcd(x,42) == 1 + +fun hamming-last( upto : int ) : div int + fold-int(1,upto,0) fn(i,acc) + if is-hamming(i) then i else acc + +fun main() + hamming-last(300000).println \ No newline at end of file diff --git a/test/bench/koka/hamming.kk b/test/bench/koka/hamming.kk new file mode 100644 index 000000000..98d10e338 --- /dev/null +++ b/test/bench/koka/hamming.kk @@ -0,0 +1,19 @@ +import std/num/int32 + +// Euclid's gcd with subtraction +fun gcd( x : int32, y : int32 ) : div int32 + if x > y + then gcd( x - y, y ) + elif x < y + then gcd( x, y - x ) + else x + +fun is-hamming( x : int32 ) : div bool + gcd(x,42.int32) == 1.int32 + +fun hamming-last( upto : int ) : div int32 + fold-int32(1.int32,upto.int32,0.int32) fn(i,acc) + if is-hamming(i) then i else acc + +fun main() + hamming-last(300000).int.println \ No newline at end of file diff --git a/test/bench/koka/pyth-int.kk b/test/bench/koka/pyth-int.kk new file mode 100644 index 000000000..2622d5561 --- /dev/null +++ b/test/bench/koka/pyth-int.kk @@ -0,0 +1,15 @@ +module pyth-int + +pub fun pyth(n : int ) : int + fold-int(1, n/3, 0) fn(x,xcount) + val xx = x*x + fold-int(x.inc, n/2, xcount) fn(y,ycount) + val yy = y*y + fold-while-int( y.inc, n/2, ycount) fn(z, zcount) + val zz = z*z + if (xx+yy == zz) then Just(zcount + 1) + elif (xx+yy >= zz) && (x+y+z <= n) then Just(zcount) + else Nothing + +pub fun main() + pyth(4000).println \ No newline at end of file diff --git a/test/bench/koka/pyth.kk b/test/bench/koka/pyth.kk new file mode 100644 index 000000000..64e3d5ca6 --- /dev/null +++ b/test/bench/koka/pyth.kk @@ -0,0 +1,17 @@ +module pyth + +import std/num/int32 + +pub fun pyth(n : int32 ) : console int32 + fold-int32(1.int32, n/3.int32, 0.int32) fn(x,xcount) + val xx = x*x + fold-int32(x.inc, n/2.int32, xcount) fn(y,ycount) + val yy = y*y + fold-while-int32( y.inc, n/2.int32, ycount) fn(z:int32, zcount:int32) + val zz = z*z + if (xx+yy == zz) then Just(zcount + 1.int32) + elif (xx+yy >= zz) && (x+y+z <= n) then Just(zcount) + else Nothing + +pub fun main() + pyth(4000.int32).int.println \ No newline at end of file diff --git a/test/bench/koka/sfib-int.kk b/test/bench/koka/sfib-int.kk new file mode 100644 index 000000000..f82ea195a --- /dev/null +++ b/test/bench/koka/sfib-int.kk @@ -0,0 +1,19 @@ +module sfib-int + +fun sfibx(n : int, x : int) : div int + if n <= 0 then x + elif x > 1000000000 + then sfibx(n - 1, 1) + else sfibx(n - 1, x*x + x + 2) + +pub fun sfib(n : int) + sfibx(n,1) + +pub fun test(n : int) + val xs = list(1,10000) + val ssum = fold-int(1,n,0) fn(i,acc) + acc + xs.sum + ssum.println + +pub fun main() + test(100000) \ No newline at end of file diff --git a/test/bench/koka/sfib.kk b/test/bench/koka/sfib.kk new file mode 100644 index 000000000..290119bc1 --- /dev/null +++ b/test/bench/koka/sfib.kk @@ -0,0 +1,17 @@ +module sfib + +import std/num/int32 + +fun sfibx(n : int32, x1 : int32, x2 : int32) : div int32 + if n <= 0.int32 + then x1 + elif x2 > 1000000000.int32 + then sfibx(n.dec, 1.int32, 2.int32) + else sfibx(n.dec, x2 - x1, x1 * x2 + x1) + +fun sfib(n : int) + sfibx(n.int32,1.int32,2.int32).int + +pub fun main() + sfib(50000000).println + diff --git a/test/bench/koka/tak-int.kk b/test/bench/koka/tak-int.kk new file mode 100644 index 000000000..a38a5189b --- /dev/null +++ b/test/bench/koka/tak-int.kk @@ -0,0 +1,10 @@ +module tak-int + +pub fun tak(x : int, y : int, z : int ) : div int + if y < x + then tak( tak(x - 1, y, z), tak(y - 1, z, x), tak(z - 1, x, y) ) + else z + +pub fun main() + // tak(18,12,6).println + tak(36,24,14).println \ No newline at end of file diff --git a/test/bench/koka/tak.kk b/test/bench/koka/tak.kk new file mode 100644 index 000000000..6f908bedc --- /dev/null +++ b/test/bench/koka/tak.kk @@ -0,0 +1,12 @@ +module tak + +import std/num/int32 + +pub fun tak(x : int32, y : int32, z : int32 ) : div int32 + if y < x + then tak( tak(x - 1.int32, y, z), tak(y - 1.int32, z, x), tak(z - 1.int32, x, y) ) + else z + +pub fun main() + // tak(18,12,6).println + tak(36.int32,24.int32,14.int32).show.println \ No newline at end of file diff --git a/test/bench/readme-icfp22.txt.md b/test/bench/readme-icfp22.txt.md new file mode 100644 index 000000000..0f0478dbc --- /dev/null +++ b/test/bench/readme-icfp22.txt.md @@ -0,0 +1,335 @@ +# ICFP Paper Artifact: Reference Counting with Frame Limited Reuse + +Docker image: daanx/icfp22-reuse:1.3 +Digest : sha256:7f6b08c4c47d47c8a532ec48d8f7e76d3ebac8de7be02aea89c685fb090699cf + +# Getting Started + +We provide a docker image (based on Ubuntu 20.04, about 5GiB) to run the benchmarks: + +``` +> docker pull daanx/icfp22-reuse:1.3 +> docker run -it daanx/icfp22-reuse:1.3 +``` + +We now see the docker prompt as: + +``` +> root@43108f4c2f0f:/build/koka/test/bench/build# +``` + +We will shorten this to `/build/koka/test/bench/build#` in the guide. +This directory also contains this README.md. + +From this prompt, we can test if we can run our benchmarks as: + +``` +/build/koka/test/bench/build# koka -e ../bench.kk -- --norm --iter=3 --test=rbtree +compile: ../bench.kk +loading: std/core +... + +tests : rbtree +languages: koka, kokax, kokaold, ocaml, haskell, swift, java, cpp, kokafbip + +run: koka/out/bench/kk-rbtree +420000 +1: elapsed: 0.43s, rss: 135428kb + +... + +--- rbtree ---------------- +rbtree, kk, 0.41s ~0.010, 135412kb +rbtree, kkx, 0.52s ~0.005, 135426kb +rbtree, kkold, 0.62s ~0.005, 170260kb +rbtree, ml, 0.65s ~0.010, 205834kb +rbtree, hs, 1.48s ~0.015, 540478kb +rbtree, sw, 5.22s ~0.141, 269242kb +rbtree, jv, 1.04s ~0.029, 1576906kb +rbtree, cpp, 0.54s ~0.019, 200170kb +rbtree, kkfbip, 0.38s ~0.017, 135476kb + +--- normalized rbtree ---------------- +rbtree, kk, 1.00x ~0.010, 1.00x +rbtree, kkx, 1.24x ~0.005, 1.00x +rbtree, kkold, 1.51x ~0.005, 1.26x +rbtree, ml, 1.57x ~0.010, 1.52x +rbtree, hs, 3.55x ~0.015, 3.99x +rbtree, sw, 12.58x ~0.141, 1.99x +rbtree, jv, 2.52x ~0.029, 11.65x +rbtree, cpp, 1.30x ~0.019, 1.48x +rbtree, kkfbip, 0.89x ~0.017, 1.00x +``` + +This runs the `rbtree` benchmark for all systems (koka, kokax, kokaold, kokafbip, ocaml, haskell, swift, java, cpp), +and eventually provides a summary in absolute runtimes (and rss), and normalized +runtimes (and rss) relative to `koka` (`kk`). + +Note that the precise results depend quite a bit on the host system -- the above results +are on a 16-core AMD 5950X @ 3.4Ghz inside the Docker container. + + +# Step-by-step Guide + +## Run All Benchmarks + +The `../bench.kk` script runs each benchmark using `/usr/bin/time` to measure +the runtime and rss. For the benchmark figures in our paper we used +the following command: + +``` +/build/koka/test/bench/build# koka -e ../bench.kk -- --norm --iter=10 +``` + +to run all benchmarks 10 times for each available language, and use the median +of those runs (and calculate the standard error interval). +The full ICFP'22 paper with supplementary material can be found +in the build directory as `reuse-supplement.pdf`. + +The expected results on an AMD5950X are at the bottom of this readme. +These should correspond closely to the results in Section 6 and Figure 8 of the paper. + +Note that results may differ across systems quite a bit (see for example the (non-anonymous) +technical report [1] that contains figures on the M1 in appendix B). +However, to support the conclusions in the paper, only the following should hold: + +1. The results for `koka`, `kokax`, and `kokaold` should be relatively the same as the + expected results for each benchmark. That is, for rbtree for example, `koka` should be fastest, + followed by `kokax` (no TRMC) and then `kokaold` (old reuse algorithm). Also, `kokaold` + should never be much faster than `koka` (within the error margin.). This supports the conclusion + that our new reuse approach is always better. +2. The `kokafbip` versions (for `rbtree`, `rbtree-ck`, and `binarytrees` only) are hopefully as fast + as `koka`. For older systems we have seen it perform less good due to cache effects + but on a modern CPU this should not be the case. (see Section 7 of the paper). +3. The relative results of all other systems (ocaml, haskell, swift, java, cpp) are less + important as those are just there to give a sense of the absolute performance of `koka` + but are not used otherwise. +4. The CPU/Cache/Memory/emulation matters: for example on the AMD5950x/x64 the `rbtree` benchmark + with `kokafbip` is over 30% faster than `cpp`, but on the M1/aarch64 only 7%. [1], or running Docker + emulated on an M1 makes Haskell use over 50x times the memory of koka on rbtree while + normally it should be no more than 5x for rbtree, etc. + + +## Benchmark Descriptions + +Running all benchmarks over all systems takes a while (10 to 30min); we can use the `--lang=` and +`--test=` options to run a particular test for a specific language, for example: + +``` +/build/koka/test/bench/build# koka -e ../bench.kk -- --norm --iter=2 --test=rbtree,binarytrees --lang=kk,ml,cpp +``` + +Available languages are: + +- `kk` : Koka v2.3.3 compiling using gcc 9.4.0. The sources of this compiler version are in + `/build/koka-v2.3.3` with the compiled binary in the `local/bin/koka` subdirectory. + The new reuse algorithm can be found in the + files `.../src/Backend/C/ParcReuse.hs` and `.../src/Backend/C/Parc.hs` ("Parc" was + the initial name for "Perceus"). +- `kkx` : Koka v2.3.3 compiling using gcc 9.4.0 but without TRMC (tail-mod-cons) optimization. +- `kkold` : Koka v2.3.3-old compiling using gcc 9.4.0. This is the compiler exactly like `kk` but + (1) using the old reuse algorithm K and (2) no borrowing, as described in the paper. + The sources of this compiler are in `/build/koka-v2.3.3-old` with the compiled binary + in the `local/bin/koka` subdirectory. These sources are just as in `v2.3.3` except for the reuse + algorithm which is the "old" algorithm K as described in the paper and no borrowing. + (This is why we cannot use the more recent (and better) koka v2.4.x versions since we only + carefully maintained the `kkold` to track `kk` up to the v2.3.3 version) +- `kkfbip`: Koka v2.3.3 compiling using gcc 9.4.0 but using the FBIP variants of the `rbtree`, + `rbtree-ck`, and `binarytrees` benchmarks as described in the paper (Section 7). +- `ml` : Multicore OCaml v4.14.0 using the optimizing compiler (`ocamlopt`) +- `hs` : Haskell GHC 8.6.5 +- `sw` : Swift 5.6.1. +- `jv` : Java 17.0.1 2021-10-19 LTS + Java(TM) SE Runtime Environment (build 17.0.1+12-LTS-39) + Java HotSpot(TM) 64-Bit Server VM (build 17.0.1+12-LTS-39, mixed mode, sharing) +- `cpp` : GCC 9.4.0 + +Available tests are described in detail in Section 4 and are: + +- `rbtree` : inserts 42 million items into a red-black tree. +- `rbtree-ck` : a variant of rbtree that keeps a list of every 5th subtree and thus shares many subtrees. +- `deriv` : the symbolic derivative of a large expression. +- `nqueens` : calculates all solutions for the n-queens problem of size 13 into a list, and returns the length of that list. +- `cfold` : constant-folding over a large symbolic expression. +- `binarytrees` : the binarytrees benchmark from the computer benchmark game + + + +## Benchmark Sources + +All the sources are in the `/build/koka/test/bench/` directories. For example: +``` +/build/koka/test/bench/build# ls ../java +CMakeLists.txt binarytrees.java cfold.java deriv.java nqueens.java rbtree.java rbtreeck.java +``` + + +## Re-build the Benchmarks + +All tests can be recompiled using: +``` +/build/koka/test/bench/build# cmake --build . +``` + +The `CMakeList.txt` file includes all language specific `/CMakeLists.txt` files +which each build all the benchmarks for each language in the most optimized way. +The `koka/CMakeLists.txt` compiles each benchmark for each of the four variants +(`kk`, `kkold`, `kkx`, and `kkfbip`). All the binaries go into `build/` +folders. + +The benchmark script `../bench.kk` is a Koka script that runs the various +benchmarks a number of times measuring runtime and memory usage with the +`time` program. It takes all results and calculates the median runtimes, and +can normalize results against Koka. + + +## Expected Results in Docker on Windows: + +These were obtained running on Windows inside a Ubuntu 20.04 x86_64 Docker +container on a 16-core AMD 5950X @ 3.4Ghz. + +``` +root@...:/build/koka/test/bench/build# koka -e ../bench.kk -- --iter=10 --norm +... +``` + +``` +--- rbtree ---------------- +rbtree, kk, 0.42s ~0.006, 135468kb +rbtree, kkx, 0.51s ~0.000, 135464kb +rbtree, kkold, 0.61s ~0.003, 170290kb +rbtree, ml, 0.64s ~0.007, 206424kb +rbtree, hs, 1.48s ~0.015, 540504kb +rbtree, sw, 5.25s ~0.095, 269428kb +rbtree, jv, 1.05s ~0.037, 1595502kb +rbtree, cpp, 0.56s ~0.013, 200186kb +rbtree, kkfbip, 0.39s ~0.007, 135468kb + +--- rbtree-ck ---------------- +rbtree-ck, kk, 1.12s ~0.035, 1181986kb +rbtree-ck, kkx, 1.12s ~0.015, 1181980kb +rbtree-ck, kkold, 1.58s ~0.024, 1181930kb +rbtree-ck, ml, 1.94s ~0.039, 1413220kb +rbtree-ck, hs, 14.71s ~0.321, 11591426kb +rbtree-ck, sw, 5.36s ~0.155, 1883714kb +rbtree-ck, jv, 2.16s ~0.010, 2322116kb +rbtree-ck, cpp, error: Command exited with non-zero status 1 +0.05 86368 +rbtree-ck, kkfbip, 1.01s ~0.043, 1182032kb + +--- binarytrees ---------------- +binarytrees, kk, 0.81s ~0.035, 682008kb +binarytrees, kkx, 0.84s ~0.036, 673168kb +binarytrees, kkold, 0.83s ~0.034, 691124kb +binarytrees, ml, 1.62s ~0.034, 175520kb +binarytrees, hs, 7.13s ~0.023, 422944kb +binarytrees, sw, 3.71s ~0.126, 736962kb +binarytrees, jv, 1.90s ~0.042, 2403894kb +binarytrees, cpp, 0.58s ~0.024, 1029256kb +binarytrees, kkfbip, 0.74s ~0.022, 657548kb + +--- deriv ---------------- +deriv, kk, 0.61s ~0.007, 469404kb +deriv, kkx, 0.63s ~0.006, 469376kb +deriv, kkold, 0.74s ~0.004, 469356kb +deriv, ml, 0.81s ~0.005, 433988kb +deriv, hs, 1.40s ~0.009, 499498kb +deriv, sw, 1.62s ~0.016, 930968kb +deriv, jv, 0.57s ~0.013, 818774kb +deriv, cpp, 0.79s ~0.013, 1053314kb +deriv, kkfbip, error: NA + +--- nqueens ---------------- +nqueens, kk, 0.48s ~0.009, 98648kb +nqueens, kkx, 0.49s ~0.003, 98594kb +nqueens, kkold, 0.74s ~0.010, 98592kb +nqueens, ml, 0.79s ~0.003, 181108kb +nqueens, hs, 6.27s ~0.015, 347984kb +nqueens, sw, 2.34s ~0.011, 326944kb +nqueens, jv, 0.77s ~0.008, 317028kb +nqueens, cpp, 0.56s ~0.008, 295512kb +nqueens, kkfbip, error: NA + +--- cfold ---------------- +cfold, kk, 0.09s ~0.003, 143756kb +cfold, kkx, 0.11s ~0.005, 143676kb +cfold, kkold, 0.08s ~0.006, 143716kb +cfold, ml, 0.35s ~0.003, 137096kb +cfold, hs, 0.37s ~0.005, 156426kb +cfold, sw, 0.68s ~0.004, 227808kb +cfold, jv, 0.22s ~0.004, 488270kb +cfold, cpp, 0.28s ~0.004, 421158kb +cfold, kkfbip, error: NA + +--- normalized rbtree ---------------- +rbtree, kk, 1.00x ~0.006, 1.00x +rbtree, kkx, 1.21x ~0.000, 1.00x +rbtree, kkold, 1.45x ~0.003, 1.26x +rbtree, ml, 1.51x ~0.007, 1.52x +rbtree, hs, 3.52x ~0.015, 3.99x +rbtree, sw, 12.49x ~0.095, 1.99x +rbtree, jv, 2.50x ~0.037, 11.78x +rbtree, cpp, 1.33x ~0.013, 1.48x +rbtree, kkfbip, 0.92x ~0.007, 1.00x + +--- normalized rbtree-ck ---------------- +rbtree-ck, kk, 1.00x ~0.035, 1.00x +rbtree-ck, kkx, 1.00x ~0.015, 1.00x +rbtree-ck, kkold, 1.41x ~0.024, 1.00x +rbtree-ck, ml, 1.73x ~0.039, 1.20x +rbtree-ck, hs, 13.14x ~0.321, 9.81x +rbtree-ck, sw, 4.79x ~0.155, 1.59x +rbtree-ck, jv, 1.93x ~0.010, 1.96x +rbtree-ck, cpp, error: Command exited with non-zero status 1 +0.05 86368 +rbtree-ck, kkfbip, 0.90x ~0.043, 1.00x + +--- normalized binarytrees ---------------- +binarytrees, kk, 1.00x ~0.035, 1.00x +binarytrees, kkx, 1.04x ~0.036, 0.99x +binarytrees, kkold, 1.02x ~0.034, 1.01x +binarytrees, ml, 1.99x ~0.034, 0.26x +binarytrees, hs, 8.75x ~0.023, 0.62x +binarytrees, sw, 4.55x ~0.126, 1.08x +binarytrees, jv, 2.34x ~0.042, 3.52x +binarytrees, cpp, 0.72x ~0.024, 1.51x +binarytrees, kkfbip, 0.91x ~0.022, 0.96x + +--- normalized deriv ---------------- +deriv, kk, 1.00x ~0.007, 1.00x +deriv, kkx, 1.03x ~0.006, 1.00x +deriv, kkold, 1.21x ~0.004, 1.00x +deriv, ml, 1.33x ~0.005, 0.92x +deriv, hs, 2.30x ~0.009, 1.06x +deriv, sw, 2.66x ~0.016, 1.98x +deriv, jv, 0.93x ~0.013, 1.74x +deriv, cpp, 1.30x ~0.013, 2.24x +deriv, kkfbip, error: NA + +--- normalized nqueens ---------------- +nqueens, kk, 1.00x ~0.009, 1.00x +nqueens, kkx, 1.01x ~0.003, 1.00x +nqueens, kkold, 1.53x ~0.010, 1.00x +nqueens, ml, 1.63x ~0.003, 1.84x +nqueens, hs, 12.93x ~0.015, 3.53x +nqueens, sw, 4.82x ~0.011, 3.31x +nqueens, jv, 1.59x ~0.008, 3.21x +nqueens, cpp, 1.15x ~0.008, 3.00x +nqueens, kkfbip, error: NA + +--- normalized cfold ---------------- +cfold, kk, 1.00x ~0.003, 1.00x +cfold, kkx, 1.22x ~0.005, 1.00x +cfold, kkold, 0.89x ~0.006, 1.00x +cfold, ml, 3.89x ~0.003, 0.95x +cfold, hs, 4.11x ~0.005, 1.09x +cfold, sw, 7.56x ~0.004, 1.58x +cfold, jv, 2.44x ~0.004, 3.40x +cfold, cpp, 3.11x ~0.004, 2.93x +cfold, kkfbip, error: NA +``` + +## Further References + +[1] Benchmark results on the M1 compiled natively to aarch64 are in appendix B of: + diff --git a/test/bench/run.kk b/test/bench/run.kk deleted file mode 100644 index 2955b6c90..000000000 --- a/test/bench/run.kk +++ /dev/null @@ -1,318 +0,0 @@ -import std/num/double -import std/os/file -import std/os/path -import std/os/env -import std/os/dir -import std/os/process -import std/os/flags - -// ---------------------------------------------------- -// Flags -// ---------------------------------------------------- - -val all-test-names = ["rbtree","rbtree-ck","deriv","nqueens","cfold","binarytrees"] -val all-lang-names = [ - ("koka","kk"), - // ("kokax","kkx"), - ("ocaml","ml"), - ("haskell","hs"), - ("swift","sw"), - ("java","jv"), - ("cpp","cpp") -] - -struct iflags { - tests : string = "" - langs : string = "" - chart : bool = False - iter : int = 1 -} - -val flag-descs : list> = { - fun set-tests( f : iflags, s : string ) : iflags { f(tests = s) } - fun set-langs( f : iflags, s : string ) : iflags { f(langs = s) } - fun set-chart( f : iflags, b : bool ) : iflags { f(chart = b) } - fun set-iter( f : iflags, i : string ) : iflags { f(iter = i.parse-int().default(1)) } - [ Flag( "t", ["test"], Req(set-tests,"test"), "comma separated list of tests" ), - Flag( "l", ["lang"], Req(set-langs,"lang"), "comma separated list of languages"), - Flag( "c", ["chart"], Bool(set-chart), "generate latex chart"), - Flag( "i", ["iter"], Req(set-iter,"N"), "use N iterations per test"), - ] -} - -fun flag-usage() { - flag-descs.usage("usage:\n koka run -- [options]\n\noptions:").println - println([ - "\nnotes:", - " tests : " ++ all-test-names.join(", "), - " languages: " ++ all-lang-names.map(snd).join(", ") - ].unlines) -} - -public fun process-flags() : maybe { - val (flags,args,errs) = parse( Iflags(), flag-descs, get-args() ) - if (errs.is-nil && args.is-nil) then { - Just(flags) - } - else { - println( errs.join("\n") ) - flag-usage() - Nothing - } -} - - -// ---------------------------------------------------- -// Test structure -// ---------------------------------------------------- - -struct test { - name: string - lang: string - elapsed: double = 0.0 - elapsed-sdev : double = 0.0 - rss: int = 0 - err: string = "" - norm-elapsed: double = 0.0 - norm-rss: double = 0.0 - norm-elapsed-sdev : double = 0.0 -} - -fun show( test : test ) { - val xs = if (test.err.is-empty) then [ - test.elapsed.core/show(2) ++ "s ~" ++ test.elapsed-sdev.core/show-fixed(3), - test.rss.core/show ++ "kb" - ] else ["error: " ++ test.err] - ([test.name,test.lang.pad-left(3)] ++ xs).join(", ") -} - -fun show-norm( test : test ) { - val xs = if (test.err.is-empty) then [ - test.norm-elapsed.core/show(2) ++ "x ~" ++ test.elapsed-sdev.core/show-fixed(3), - test.norm-rss.core/show(2) ++ "x" - ] else ["error: " ++ test.err] - ([test.name,test.lang.pad-left(3)] ++ xs).join(", ") -} - -// ---------------------------------------------------- -// main -// ---------------------------------------------------- -public fun main() { - match (process-flags()) { - Nothing -> () - Just(flags) { - val test-names = if (flags.tests.is-empty) then all-test-names - else flags.tests.split(",") - val lang-names = if (flags.langs.is-empty) then all-lang-names - else all-lang-names.filter(fn(l){ flags.langs.contains(l.snd) || flags.langs.contains(l.fst) }) - run-tests(test-names,lang-names,flags.chart,flags.iter) - } - } -} - -fun run-tests(test-names : list, lang-names : list<(string,string)>, gen-chart : bool, iterations : int ) { - println("tests : " ++ test-names.join(", ")) - println("languages: " ++ lang-names.map(fst).join(", ")) - - // run tests - val alltests = test-names.flatmap fn(test-name){ - lang-names.map fn(lang){ - run-test( test-name, lang, iterations ) - } - } - - // show test results - test-names.foreach fn(test-name){ - val tests = alltests.filter(fn(t){ t.name == test-name }) - println("\n--- " ++ test-name ++ " ----------------") - println(tests.map(show).join("\n")) - } - - // exit if koka is not part of the tests (since we need it to normalize) - if (!lang-names.map(fst).join(",").contains("koka")) return () - - // normalize tests - val all-ntests = test-names.flatmap fn(test-name){ - val tests = alltests.filter(fn(t){ t.name == test-name }) - - // normalize to koka - val koka = match(tests.filter(fn(t){t.lang == "kk"})) { Cons(t,Nil) -> t } - val ntests = tests.map fn(t) { - val norm = if (koka.elapsed==0.0) then 1.0 else t.elapsed / koka.elapsed - t(norm-elapsed = norm, - norm-rss = if (koka.rss==0) then 1.0 else t.rss.double / koka.rss.double, - norm-elapsed-sdev = norm * t.elapsed-sdev) - } - println("\n--- normalized " ++ test-name ++ " ----------------") - println(ntests.map(show-norm).join("\n")) - ntests - } - - // group by language - val lang-ntests = lang-names.map(fn(l) { - val lang-name = l.snd - (lang-name, all-ntests.filter(fn(t:test){ t.lang == lang-name })) - }) - - // emit latex chart - if (gen-chart) then { - val ymax = 2.0 - val chart-desc = @"6-core AMD 3600XT at 3.8Ghz\\Ubuntu 20.04, Gcc 9.3.0" - val chart-elapsed = chart("time", norm-elapsed, norm-elapsed-sdev, test-names, lang-ntests, ymax, chart-desc) - val chart-rss = chart("rss", norm-rss, fn(t){ 0.0 }, test-names, lang-ntests, ymax, chart-desc) - println("\n") - println(chart-elapsed) - println("\n") - println(chart-rss) - } - () -} - - -// ---------------------------------------------------- -// Latex chart -// ---------------------------------------------------- -fun chart( kind : string, norm : test -> double, norm-sdev : test -> double, test-names : list, lang-ntests : list<(string,list)>, ymax : double = 2.0, desc : string = "" ) : string { - [ tikz-header(test-names,".bench" ++ kind) - , lang-ntests.flatmap(fn(l){ tikz-data(kind, norm, norm-sdev, l, ymax = ymax ) }) - , tikz-picture(kind, test-names, lang-ntests.map(fst), ymax = ymax, desc = desc ) - , tikz-footer(test-names) ].concat.join("\n") -} - - -fun tikz-header( test-names : list, attr : string ) : list { - ["~ Begin Snippet { .benchmark " ++ attr ++ " }", - "\\pgfplotsset{", - " xticklabels = {" ++ test-names.map(fn(n){ "\\strut " ++ n.replace-all("_","\\_")}).join(",") ++ "}", - "}"] -} - -fun tikz-footer( test-names : list ) : list { - [ "~ End Snippet" ] -} - -fun tikz-picture( kind : string, test-names : list, lang-names : list, ymax : double = 2.0, desc : string = "", height:string = "6cm", width:string = "9cm" ) { - val n = test-names.length - 1 - val header = [ - @"", - @"\begin{tikzpicture}\sffamily", - @"\begin{axis}[Chart" ++ kind ++ ",ymax=" ++ ymax.show(1) ++ ",height=" ++ height ++ ",xmax=" ++ n.show ++ ".5,width=" ++ width ++ "]", - @" \draw (axis cs:-0.5,1) -- (axis cs:" ++ n.show ++ ".5,1);" - ] - val mid = lang-names.map(fn(l){ @" \draw" ++ kind ++ @"{\color" ++ kind ++ l ++ @"{0}}{\data" ++ kind ++ l ++ "};"}) - val footer = [ - if (kind=="time") then @" \legend{" ++ lang-names.map(fn(l){ "\\lang" ++ l }).join(",") ++ "};" - else "", - // if (desc.is-empty) then "" else @" \chartdesc{" ++ desc.replace-all("\n",@"\\") ++ "};", - @"\end{axis}", - @"\end{tikzpicture}" - ] - (header ++ mid ++ footer) -} - - -fun tikz-data( kind:string, norm : test -> double, norm-sdev : test -> double, lang-ntests : (string,list), ymax : double = 2.0 ) : list { - val (lang,ntests) = lang-ntests - ["", - @"\pgfplotstableread{"] ++ - ntests.map-indexed(fn(i,t){ - if (t.err.is-empty) then { - [i.show, - if (t.norm <= ymax) then t.norm.show-fixed(3) else ymax.show-fixed(3), - if (t.norm > ymax || t.norm-sdev < 0.001) then "0.000" else t.norm-sdev.show-fixed(3), - t.norm.show-fixed(2) // else @"{\outerlabel{" ++ t.norm-elapsed.show(2) ++ "}}" - ].join(" ") - } - else (i.show ++ @" 0.100 0.000 " ++ (if (i==0) then "0" elif (t.err=="NA") then "{NA}" else @"{\ensuremath{\times}}")) - }) ++ - [@"}\data" ++ kind ++ lang] -} - - -// ---------------------------------------------------- -// Run a single test -// ---------------------------------------------------- - -fun run-test( test-name : string, langt : (string,string), iterations : int ) : io test { - val (lang-long,lang) = langt - val pre = lang.pad-left(3) ++ ", " ++ test-name.pad-left(12) ++ ", " - val dir = if (lang=="kk") then "koka/out/bench" - elif (lang=="kkx") then "koka/outx/bench" - else lang-long - val base = lang ++ "-" ++ test-name - val prog = if (lang-long=="java") - then "java --enable-preview --class-path=" ++ dir ++ " " - ++ (if (test-name=="cfold") then "-Xss128m " else "") - ++ test-name.replace-all("-","") - else dir ++ "/" ++ base - val progpath = if (lang-long=="java") then (dir.path / (test-name.replace-all("-","") ++ ".class")) - else prog.path - println("\nrun: " ++ prog) - - if (!is-file(progpath)) then { - return Test(test-name,lang,err="NA") - } - - val results = list(1,iterations) - .map( fn(i){ execute-test(i,base,prog)} ) - .map( fn(r){ - match(r) { - Left(err) -> Test(test-name,lang,err=err) - Right((elapsed,rss)) -> Test(test-name,lang,elapsed = elapsed, rss = rss) - }}) - match(results.filter(fn(t){ !t.err.is-empty })) { - Cons(t) -> return t - _ -> () - } - - // filter out worst time if more than 2 iterations - val slowest = results.map(fn(t){ t.elapsed }).maximum - val m = results.filter(fn(t){ t.elapsed == slowest }).length - val resultsf = if (m==1 && results.length > 2) - then results.filter(fn(t){ t.elapsed < slowest }) - else results - // take the average of the rest - val n = resultsf.length - val test = resultsf.foldl1( fn(t1,t2){ t1( elapsed = t1.elapsed + t2.elapsed, rss = t1.rss + t2.rss ) } ) - - // calc. stddev - val avg = test.elapsed / n.double - val sdev = sqrt( resultsf.map( fn(t){ sqr(t.elapsed - avg) } ).sum / n.double ) - - test( elapsed = avg, elapsed-sdev = sdev, rss = test.rss / n ) -} - -fun test-sum( t1 : test, t2 : test) : test { - t1( elapsed = t1.elapsed + t2.elapsed, rss = t1.rss + t2.rss ) -} - -fun execute-test( run : int, base : string, prog : string ) : io either { - val timef= "time-" ++ base ++ ".txt" - val system = run-system-read("uname -s").exn - val cmd = if (system == "Darwin") - then "/usr/bin/time -l 2> " ++ timef ++ " " ++ prog - else "/usr/bin/time -f'%e %M' -o" ++ timef ++ " " ++ prog - val out = run-system-read(cmd).exn - print(out) - val time = read-text-file(timef.path).trim - if (time=="") return Left("no output") - match(time.list) { - Nil -> Left("no output") - Cons(d) | !d.is-digit -> Left(time) // error - _ -> { - val parts = time.replace-all("\n"," ").replace-all("\t"," ").split(" ").filter(fn(p){ !p.is-empty }) - // println( parts.join(",") ) - match(parts) { - Cons(elapsed,Cons(rss,Nil)) { // linux - println(run.show ++ ": elapsed: " ++ elapsed ++ "s, rss: " ++ rss ++ "kb" ) - Right( (parse-double(elapsed).default(0.0), parse-int(rss).default(0)) ) - } - Cons(elapsed,Cons("real",Cons(_,Cons(_user,Cons(_,Cons(_sys,Cons(rss,_))))))) { // on macOS - println(run.show ++ ": elapsed: " ++ elapsed ++ "s, rss: " ++ rss ++ "b" ) - Right( (parse-double(elapsed).default(0.0), parse-int(rss).default(0)/1024) ) - } - _ -> Left("bad format") - } - } - } -} diff --git a/test/cgen/ctail10.kk b/test/cgen/ctail10.kk new file mode 100644 index 000000000..1900b0d4e --- /dev/null +++ b/test/cgen/ctail10.kk @@ -0,0 +1,38 @@ +type tree + Bin(l : tree, x : a, r : tree) + Tip + +fun tree(n : int) + if n <= 0 + then Tip + else + val m = n - 1 + val l = tree( m / 2 ) + val r = tree( m - m / 2 ) + Bin(l, n, r) + +fun tmap(t : tree, f : a -> e b) : e tree + match t + Bin(l, x, r) -> Bin(l.tmap(f), f(x), r.tmap(f)) + Tip -> Tip + + +fun tmap1(t : tree, f : a -> e b) : e tree + match t + Tip -> Tip + _ -> tmap(t,f) + +fun tsum(t : tree) : div int + tsum'(t, 0) + +fun tsum'(t : tree, acc : int) : div int + match t + Tip -> acc + Bin(l, x, r) -> tsum'(l, tsum'(r, acc + x)) + +fun test(n : int) + val t = tree(n) + val x = fold-int(0,100000000/(if n<=0 then 1 else n),0) fn(i,acc) + acc + t.tmap(fn(x){ x+1 }).tsum + //acc + t.tmap1(fn(x){ x+1 }).tsum + println("total: " ++ x.show) \ No newline at end of file diff --git a/test/cgen/ctail2a.kk b/test/cgen/ctail2a.kk new file mode 100644 index 000000000..90d999777 --- /dev/null +++ b/test/cgen/ctail2a.kk @@ -0,0 +1,11 @@ + +fun mapx( xs : list, f : a -> total b ) : total list { + match(xs) { + Cons(x,xx) -> Cons(f(x),xx.mapx(f)) + Nil -> Nil + } +} + +fun main() { + list(1,10).mapx(fn(i){ i+1 }).sum.println +} diff --git a/test/cgen/ctail3b.kk b/test/cgen/ctail3b.kk index 4a6ecba92..5f4b4fea9 100644 --- a/test/cgen/ctail3b.kk +++ b/test/cgen/ctail3b.kk @@ -11,6 +11,6 @@ fun mapx( xs : list, f : a -> e b ) : e list { } fun main() { - with fun out(s:string) { if (s=="9") throw(s); println(s) } - list(1,10).mapx(fn(i:int){ if (i.is-odd) i.show.out; i+1 }).sum.println + with fun out(s:string) { if s=="9" then throw(s); println(s) } + list(1,10).mapx(fn(i:int){ if i.is-odd then i.show.out; i+1 }).sum.println } diff --git a/test/cgen/ctail5.kk b/test/cgen/ctail5.kk index ba7ad17d0..e98d673c6 100644 --- a/test/cgen/ctail5.kk +++ b/test/cgen/ctail5.kk @@ -3,32 +3,28 @@ effect nondet { ctl fail() : a } -fun knapsack(w : int, vs : list ) : list { +fun knapsack(w : int, vs : list ) : list if (w < 0) then fail() elif (w == 0) then [] - else { + else val v = select(vs) Cons(v,knapsack(w - v, vs)) - } -} - -fun select(xs) { - match(xs) { + +fun select(xs) + match xs Nil -> fail() - Cons(x,xx) -> if (flip()) then x else select(xx) - } -} + Cons(x,xx) -> if flip() then x else select(xx) + +val solutions = handler + return(x) [x] + ctl fail() [] + ctl flip() resume(True) ++ resume(False) -val solutions = handler { - return x -> [x] - ctl fail() -> [] - ctl flip() -> resume(True) + resume(False) -} -fun show( xss : list> ) : string { - xss.show-list(fn(xs) { xs.show-list(core/show) } ) -} +fun show( xss : list> ) : string + xss.show-list( fn(xs) xs.show-list(core/show) ) + -fun main() { +fun main() solutions{ knapsack(3,[3,2,1]) } -} + diff --git a/test/cgen/ctail5a.kk b/test/cgen/ctail5a.kk new file mode 100644 index 000000000..384da7f89 --- /dev/null +++ b/test/cgen/ctail5a.kk @@ -0,0 +1,36 @@ +// non deteministic TRMC over binary trees +// this tests the context copying code. +effect nondet + ctl flip() : bool + ctl fail() : a + +type tree + Bin(l:tree, r:tree) + Tip(value:int) + +fun tmap( t : tree, f : int -> e int ) : e tree + match t + Bin(l,r) -> Bin(tmap(l,f),tmap(r,f)) + Tip(i) -> Tip(f(i)) + + +fun tshow( t : tree ) : string + match t + Bin(l,r) -> "Bin(" ++ l.tshow ++ "," ++ r.tshow ++ ")" + Tip(i) -> "Tip(" ++ i.show ++ ")" + +fun incs( t : tree ) : nondet tree + t.tmap fn(i) + if flip() then i + 1 else i - 1 + + +val solutions = handler + return(x) [x] + ctl fail() [] + ctl flip() resume(True) ++ resume(False) + +fun main() + val t = Bin(Bin(Tip(1),Tip(2)),Bin(Tip(3),Tip(4))) + val ts = solutions{ incs(t) } + ts.show-list(tshow).println + diff --git a/test/cgen/ctail7a.kk b/test/cgen/ctail7a.kk index 09e4f66c2..1296da286 100644 --- a/test/cgen/ctail7a.kk +++ b/test/cgen/ctail7a.kk @@ -3,8 +3,8 @@ type tree Tip Node( left : ind, right : ind ) -reference type ind - Ind( ind : a ) +ref type ind + Ind( ind : a) fun make( depth : int ) : tree if depth > 0 then diff --git a/test/cgen/ctail7c.kk b/test/cgen/ctail7c.kk index 2bb4c5f54..2aeaa6c3b 100644 --- a/test/cgen/ctail7c.kk +++ b/test/cgen/ctail7c.kk @@ -3,8 +3,8 @@ type tree Tip Node( left : ind, right : ind ) -reference type ind - Ind( ind : a ) +ref type ind + Ind( ind : a) fun make( depth : int ) : console tree if depth > 0 then diff --git a/test/cgen/ctail9.kk b/test/cgen/ctail9.kk new file mode 100644 index 000000000..571c7104f --- /dev/null +++ b/test/cgen/ctail9.kk @@ -0,0 +1,23 @@ + +fun mapxx( xs : list, f : a -> e b ) : e list { + match(xs) { + Cons(x,xx) -> Cons(f(x),xx.mapxx(f)) + Nil -> Nil + } +} + +fun mapx( xs : list, f : a -> e b ) : e list { + match(xs) { + Nil -> Nil + _ -> xs.mapxx(f) + } +} + +fun test(n : int) { + val xs = list(1,n) + val x = fold-int(0,100000000/(if n<=0 then 1 else n),0) fn(i,acc) + acc + xs.mapxx(fn(x){ x+1 }).sum + //acc + xs.mapx(fn(x){ x+1 }).sum + println("total: " ++ x.show) +} + diff --git a/test/cgen/data1.kk b/test/cgen/data1.kk index 007172130..2ffd0e30d 100644 --- a/test/cgen/data1.kk +++ b/test/cgen/data1.kk @@ -9,27 +9,32 @@ | DataOpen */ -extern import { - c "" -} - // enum type void // enum -type unit { Unit() } +type unit + Unit // enum -type bool { False; True } +type bool + False + True // iso -type iso { Iso(x:int) } +type iso + Iso(x:int) + +ref type any + Any // single struct -type pair { Pair(x:a, y:b) } +value type pair { Pair(x:a, y:b) } type triple { Triple(p:pair,z:c) } +value struct vtriple(p:pair,z:c) + // single type single { Single( x:int, y:a, z:bool ) } @@ -39,20 +44,35 @@ type list { Cons(x:a,tail:list); Nil } // single normal type single-normal { Single-normal( x:a, y:maybe, z:pair ); Single-normal-extra() } -// struct -type strct { Strct( x:a, i:int ); Strct2(d:float64,s:string); Strct3(i:int32) } +// struct (as normal) +type vstrct { VStrct( x:a, i:int ); VStrct2(d:float64,s:string); VStrct3(i:int32) } // struct -type maybe { Just(x:a); Nothing } +type strct { Strct( x:a, i:int ); Strct2(i:int, s:string); Strct3(x:a) } + +// reference maybe +ref type rmaybe { RJust(x:a); RNothing } + +fun test-rmaybe( m : rmaybe ) : int + match m + RJust(i) -> i + RNothing -> 0 + +value type vmaybe { VJust(x:a); VNothing } + +fun test-vmaybe( m : vmaybe ) : int + match m + VJust(i) -> i + VNothing -> 0 // normal type normal { One(x:a,y:pair,z:pair); Two(x:int); Three } // open -type open open { Open1(:a) } +open type open { Open1(:a) } -// type extend open { Open2(:int) } +extend type open { Open2(:int) } // mixed raw / scan type point { Point(x:float64,y:float64,z:int) } @@ -64,3 +84,10 @@ type mix { Mix( p:point, m : mix, i : int32, c : char ); MixNil } // ensure the tag of maybe is in the scanned fields (3+1) type scantag { ScanTag( i : int, z : char, m : maybe, p : point ) } + + +// test padding between field and raw +value struct intdouble( i : int, d : float64 ) + +// test explicit padding between fields and mixed intdouble +struct padding( x : int, y : int, id : intdouble ) \ No newline at end of file diff --git a/test/cgen/inline4.kk b/test/cgen/inline4.kk new file mode 100644 index 000000000..3df04115b --- /dev/null +++ b/test/cgen/inline4.kk @@ -0,0 +1,39 @@ +import std/num/int32 +import std/os/env + +type tree + Leaf + Bin(l : tree, a : a, r : tree) + +fun tree32(lo : int32, hi : int32) + if lo > hi then Leaf + else + val mi = lo + (hi - lo) / 2.int32 + Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) + +fun tsum32(t0 : tree) + fun go(t, acc : int32) + match t + Leaf -> acc + Bin(l, a, r) -> go(r, go(l, acc + a)) + go(t0, 0.int32) + +fun compose(f,g) + fn(x) f(g(x)) + +fun tmap-cps( xs : tree, f : a -> e b, k : tree -> e tree ) : e tree + match xs + Bin(l,x,r) -> l.tmap-cps(f, compose(k, fn(l') { + val y = f(x) + r.tmap-cps(f, fn(r') Bin(l', y, r'))})) + Leaf -> k(Leaf) + +fun test(n : int32) + val xs = tree32(1.int32,n) + val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + acc + xs.tmap-cps(fn(x) x.inc, id).tsum32 + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/cgen/javascript.kk.out b/test/cgen/javascript.kk.out index ae9a6e8d2..0e3c901be 100644 --- a/test/cgen/javascript.kk.out +++ b/test/cgen/javascript.kk.out @@ -1,4 +1,5 @@ 3add default effect for std/core/exn -test/cgen/javascript.kk(84, 3): warning: Some branches in the match will never be reached: _ +test/cgen/javascript.kk(81, 1): warning: Type person may be better declared as a value type for efficiency (e.g. 'value type/struct'), + or declared as a reference type to suppress this warning (e.g. 'ref type/struct') test/cgen/javascript.kk(84, 3): warning: Some branches in the match will never be reached: _ \ No newline at end of file diff --git a/test/cgen/rec5.kk.out b/test/cgen/rec5.kk.out index a6f694b50..42562f7ac 100644 --- a/test/cgen/rec5.kk.out +++ b/test/cgen/rec5.kk.out @@ -1,4 +1,3 @@ 1add default effect for std/core/exn -test/cgen/rec5.kk(2,13): warning: xs shadows an earlier local definition or parameter test/cgen/rec5.kk(2,13): warning: xs shadows an earlier local definition or parameter \ No newline at end of file diff --git a/test/cgen/shortcircuit1.kk b/test/cgen/shortcircuit1.kk new file mode 100644 index 000000000..457be00c6 --- /dev/null +++ b/test/cgen/shortcircuit1.kk @@ -0,0 +1,23 @@ +effect choose + ctl flip() : bool + +fun mystery() : bool + val b = flip() + println("b = " ++ b.show) + b + +// is `mystery` ever true? +fun satisfiable-no-short-circuit() : bool + with ctl flip() + // for each input flip(), try both values + ( (resume(True) || resume(False)) : bool ) + mystery() + +fun satisfiable-short-circuit() : bool + with ctl flip() + (resume(True) : bool) || resume(False) + mystery() + +fun main() + satisfiable-no-short-circuit().println + satisfiable-short-circuit().println diff --git a/test/cgen/shortcircuit1.kk.out b/test/cgen/shortcircuit1.kk.out new file mode 100644 index 000000000..42048c21f --- /dev/null +++ b/test/cgen/shortcircuit1.kk.out @@ -0,0 +1,4 @@ +b = True +True +b = True +True \ No newline at end of file diff --git a/test/cgen/spec1.kk b/test/cgen/spec1.kk new file mode 100644 index 000000000..5fa3d5217 --- /dev/null +++ b/test/cgen/spec1.kk @@ -0,0 +1,9 @@ +fun test-many() + var i := 0 + for(1,10000000) fn(j) + i := i + 1 + println(i) + + +fun main() + test-many() diff --git a/test/cgen/specialize/bintree.kk.out b/test/cgen/specialize/bintree.kk.out index 7197c329a..89f216782 100644 --- a/test/cgen/specialize/bintree.kk.out +++ b/test/cgen/specialize/bintree.kk.out @@ -1,5 +1,6 @@ -cgen/specialize/bintree/.lift000-main: (tree : tree) -> tree -cgen/specialize/bintree/.lift000-main: (xs0 : list) -> list +cgen/specialize/bintree/.lift000-main: (tree350 : tree) -> tree +cgen/specialize/bintree/.lift000-main: (xs358 : list) -> list +cgen/specialize/bintree/.lift000-main: (xs363 : list) -> list cgen/specialize/bintree/is-bin: forall (tree : tree) -> bool cgen/specialize/bintree/is-leaf: forall (tree : tree) -> bool cgen/specialize/bintree/main: () -> () diff --git a/test/cgen/specialize/branch.kk b/test/cgen/specialize/branch.kk index 8cce54492..1eeab5caa 100644 --- a/test/cgen/specialize/branch.kk +++ b/test/cgen/specialize/branch.kk @@ -5,7 +5,7 @@ fun map_other(xs : list, f : a -> b, g : a -> b) : list { // this branch gets specialized Cons(x, xx) | isEven -> Cons(f(x), xx.map_other(f, g)) // this branch does not since f and g are passed in a different order - | _ -> Cons(g(x), xx.map_other(g, f)) + | True -> Cons(g(x), xx.map_other(g, f)) } } diff --git a/test/cgen/specialize/branch.kk.out b/test/cgen/specialize/branch.kk.out index 0986058a1..38f927275 100644 --- a/test/cgen/specialize/branch.kk.out +++ b/test/cgen/specialize/branch.kk.out @@ -3,7 +3,8 @@ 2 5 -cgen/specialize/branch/.lift000-main: (xs : list) -> console () -cgen/specialize/branch/.lift000-main: forall<_e> (xs0 : list) -> list +cgen/specialize/branch/.lift000-main: (xs416 : list) -> console () +cgen/specialize/branch/.lift000-main: (xs421 : list) -> console () +cgen/specialize/branch/.lift000-main: forall<_e> (xs428 : list) -> list cgen/specialize/branch/main: () -> console () cgen/specialize/branch/map_other: forall (xs : list, f : (a) -> b, g : (a) -> b) -> list \ No newline at end of file diff --git a/test/cgen/specialize/config.json b/test/cgen/specialize/config.json index 59d92c828..f218417c6 100644 --- a/test/cgen/specialize/config.json +++ b/test/cgen/specialize/config.json @@ -1 +1 @@ -"-e --showhiddentypesigs --fno-opttrmc -O1" +"-e --showhiddentypesigs --fno-trmc -O1" diff --git a/test/cgen/specialize/fold1.kk.out b/test/cgen/specialize/fold1.kk.out index 64d036541..759efe184 100644 --- a/test/cgen/specialize/fold1.kk.out +++ b/test/cgen/specialize/fold1.kk.out @@ -4,8 +4,7 @@ add default effect for std/core/exn cgen/specialize/fold1/.hmain: () -> console () -cgen/specialize/fold1/.lift000-main: (xs : list, z : int) -> int -cgen/specialize/fold1/.mlift000-op: (xx : list, int) -> int +cgen/specialize/fold1/.lift000-main: (xs655 : list, z656 : int) -> int cgen/specialize/fold1/.mlift000-main: (int) -> () cgen/specialize/fold1/.mlift000-main: (int) -> () cgen/specialize/fold1/.mlift000-main: (int) -> () diff --git a/test/cgen/specialize/fold2.kk.out b/test/cgen/specialize/fold2.kk.out index 15574c01f..dcbcffeb2 100644 --- a/test/cgen/specialize/fold2.kk.out +++ b/test/cgen/specialize/fold2.kk.out @@ -1,5 +1,5 @@ 55 -cgen/specialize/fold2/.lift135-main: (xs : list, z : int) -> console int -cgen/specialize/fold2/.lift136-main: (xs0 : list, z0 : int) -> console int +cgen/specialize/fold2/.lift000-main: (xs231 : list, z232 : int) -> console int +cgen/specialize/fold2/.lift000-main: (xs243 : list, z244 : int) -> console int cgen/specialize/fold2/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/localdef.kk.out b/test/cgen/specialize/localdef.kk.out index d4b300162..6cca3b5e6 100644 --- a/test/cgen/specialize/localdef.kk.out +++ b/test/cgen/specialize/localdef.kk.out @@ -1,7 +1,7 @@ ["0","1","2","3","4","5","6","7","8","9","10"] cgen/specialize/localdef/.lift000-li: forall (f : (int) -> e a, low : int, high : int, acc : list) -> e list -cgen/specialize/localdef/.lift000-main: (low : int, high : int, acc : list) -> console list -cgen/specialize/localdef/.mlift000-op: forall (acc : list, f : (int) -> e a, a00.000 : int, low : int, a) -> e list +cgen/specialize/localdef/.lift000-main: (low317 : int, high318 : int, acc319 : list) -> console list +cgen/specialize/localdef/.mlift000-lift207-li: forall (acc : list, f : (int) -> e a, a00.000 : int, low : int, a) -> e list cgen/specialize/localdef/li: forall (lo : int, hi : int, f : (int) -> e a) -> e list cgen/specialize/localdef/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/map-alias.kk.out b/test/cgen/specialize/map-alias.kk.out index 9e858963b..b2be383fe 100644 --- a/test/cgen/specialize/map-alias.kk.out +++ b/test/cgen/specialize/map-alias.kk.out @@ -1,6 +1,7 @@ [2,3,4] -cgen/specialize/map-alias/.lift000-main: (xs : list) -> console list +cgen/specialize/map-alias/.lift000-main: (xs411 : list) -> console list +cgen/specialize/map-alias/.lift000-main: (xs416 : list) -> console list cgen/specialize/map-alias/main: () -> console () cgen/specialize/map-alias/map2: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map-alias/map3: forall (xs : list, f : (a) -> e b) -> e list \ No newline at end of file diff --git a/test/cgen/specialize/map.kk.out b/test/cgen/specialize/map.kk.out index e209a49f1..95e59bbd5 100644 --- a/test/cgen/specialize/map.kk.out +++ b/test/cgen/specialize/map.kk.out @@ -1,7 +1,8 @@ [2,3,4] -cgen/specialize/map/.lift000-test: (xs : list) -> list -cgen/specialize/map/.lift000-main: (xs : list) -> list +cgen/specialize/map/.lift000-test: (xs226 : list) -> list +cgen/specialize/map/.lift000-main: (xs234 : list) -> list +cgen/specialize/map/.unroll117-map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map/main: () -> console () cgen/specialize/map/map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map/test: () -> list \ No newline at end of file diff --git a/test/cgen/specialize/map2.kk.out b/test/cgen/specialize/map2.kk.out index 145e83417..25c72bb68 100644 --- a/test/cgen/specialize/map2.kk.out +++ b/test/cgen/specialize/map2.kk.out @@ -1,7 +1,8 @@ [3,4,5] -cgen/specialize/map2/.lift000-test: (y : int, xs : list) -> list -cgen/specialize/map2/.lift000-main: (xs : list) -> list +cgen/specialize/map2/.lift000-test: (y : int, xs236 : list) -> list +cgen/specialize/map2/.lift000-main: (xs244 : list) -> list +cgen/specialize/map2/.unroll124-map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map2/main: () -> console () cgen/specialize/map2/map-int: (xs : list, f : (int) -> int) -> list cgen/specialize/map2/test: (y : int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/map3.kk.out b/test/cgen/specialize/map3.kk.out index 7a2ff2bb1..0087d3d19 100644 --- a/test/cgen/specialize/map3.kk.out +++ b/test/cgen/specialize/map3.kk.out @@ -1,9 +1,10 @@ [6,7,8,9,10,11,12,13,14,15] -cgen/specialize/map3/.lift000-test: (y : int, xs0 : list) -> list -cgen/specialize/map3/.lift000-main: (xs : list) -> list -cgen/specialize/map3/.mlift000-map-poly: forall (a, list) -> e list -cgen/specialize/map3/.mlift000-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list +cgen/specialize/map3/.lift000-test: (y : int, xs391 : list) -> list +cgen/specialize/map3/.lift000-main: (xs399 : list) -> list +cgen/specialize/map3/.mlift000-unroll278-map-poly: forall (a, list) -> e list +cgen/specialize/map3/.mlift000-unroll278-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list +cgen/specialize/map3/.unroll278-map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map3/main: () -> console () cgen/specialize/map3/map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map3/test: (xs : list, y : int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/map4.kk.out b/test/cgen/specialize/map4.kk.out index 08a352ba3..fc78d6846 100644 --- a/test/cgen/specialize/map4.kk.out +++ b/test/cgen/specialize/map4.kk.out @@ -1,9 +1,10 @@ 160 -cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs0 : list) -> list -cgen/specialize/map4/.lift000-main: (xs : list) -> list -cgen/specialize/map4/.mlift000-map-poly: forall (a, list) -> e list -cgen/specialize/map4/.mlift000-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list +cgen/specialize/map4/.lift000-test: forall (g : (a) -> int, y : int, xs326 : list) -> list +cgen/specialize/map4/.lift000-main: (xs334 : list) -> list +cgen/specialize/map4/.mlift000-unroll211-map-poly: forall (a, list) -> e list +cgen/specialize/map4/.mlift000-unroll211-map-poly: forall (f : (a) -> e b, xx : list, b) -> e list +cgen/specialize/map4/.unroll211-map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map4/main: () -> console () cgen/specialize/map4/map-poly: forall (xs : list, f : (a) -> e b) -> e list cgen/specialize/map4/test: forall (xs : list, y : int, g : (a) -> int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/map5.kk.out b/test/cgen/specialize/map5.kk.out index 0307ea336..06571f5e4 100644 --- a/test/cgen/specialize/map5.kk.out +++ b/test/cgen/specialize/map5.kk.out @@ -1,6 +1,8 @@ 115 -cgen/specialize/map5/.lift000-test: forall (f : (a) -> int, y : int, xs0 : list) -> list -cgen/specialize/map5/.lift000-main: (xs : list) -> list +cgen/specialize/map5/.lift000-test: forall (f : (a) -> int, y : int, xs359 : list) -> list +cgen/specialize/map5/.lift000-test: forall (f : (a) -> int, y : int, xs364 : list) -> list +cgen/specialize/map5/.lift000-main: (xs372 : list) -> list +cgen/specialize/map5/.lift000-main: (xs377 : list) -> list cgen/specialize/map5/main: () -> console () cgen/specialize/map5/test: forall (xs : list, y : int, f : (a) -> int) -> list \ No newline at end of file diff --git a/test/cgen/specialize/maptwice.kk.out b/test/cgen/specialize/maptwice.kk.out index aec55f4f0..f81a5f1e5 100644 --- a/test/cgen/specialize/maptwice.kk.out +++ b/test/cgen/specialize/maptwice.kk.out @@ -2,8 +2,10 @@ add default effect for std/core/exn cgen/specialize/maptwice/.hmain: () -> console () -cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs : list>) -> total list> -cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs : list>) -> total list> +cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs666 : list>) -> total list> +cgen/specialize/maptwice/.lift000-maptwice: (f : (int) -> int, xs671 : list>) -> total list> +cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs679 : list>) -> total list> +cgen/specialize/maptwice/.lift000-main: (f : (int) -> int, xs684 : list>) -> total list> cgen/specialize/maptwice/.mlift000-main: (int) -> exn () cgen/specialize/maptwice/.mlift000-main: (list) -> exn () cgen/specialize/maptwice/main: () -> () diff --git a/test/cgen/specialize/sieve.kk.out b/test/cgen/specialize/sieve.kk.out index ae9803b89..39bdc88c0 100644 --- a/test/cgen/specialize/sieve.kk.out +++ b/test/cgen/specialize/sieve.kk.out @@ -23,9 +23,13 @@ 89 97 -cgen/specialize/sieve/.lift000-sieve: (x : int, xs0 : list) -> div list -cgen/specialize/sieve/.lift000-test: (xs : list) -> () -cgen/specialize/sieve/.lift000-main: (xs : list) -> () +cgen/specialize/sieve/.lift000-unroll238-sieve: (x : int, xs348 : list) -> div list +cgen/specialize/sieve/.lift000-unroll238-sieve: (x : int, xs353 : list) -> div list +cgen/specialize/sieve/.lift000-test: (xs363 : list) -> () +cgen/specialize/sieve/.lift000-test: (xs368 : list) -> () +cgen/specialize/sieve/.lift000-main: (xs375 : list) -> () +cgen/specialize/sieve/.lift000-main: (xs380 : list) -> () +cgen/specialize/sieve/.unroll238-sieve: (xs : list, max : int) -> div list cgen/specialize/sieve/gen-primes: (n : int) -> div list cgen/specialize/sieve/main: () -> () cgen/specialize/sieve/sieve: (xs : list, max : int) -> div list diff --git a/test/cgen/specialize/tree-list.kk.out b/test/cgen/specialize/tree-list.kk.out index 48cab6312..3de48545a 100644 --- a/test/cgen/specialize/tree-list.kk.out +++ b/test/cgen/specialize/tree-list.kk.out @@ -1,12 +1,15 @@ Tree(2, [Tree(3, []), Tree(4, [])]) cgen/specialize/tree-list/.copy: forall (tree, data : optional, children : optional>>) -> tree -cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs : list>) -> list> -cgen/specialize/tree-list/.lift000-show: (xs : list>) -> div list +cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1187 : list>) -> list> +cgen/specialize/tree-list/.lift000-mapT: forall (f : (a) -> b, xs1192 : list>) -> list> +cgen/specialize/tree-list/.lift000-show: (xs1200 : list>) -> div list +cgen/specialize/tree-list/.lift000-show: (xs1205 : list>) -> div list cgen/specialize/tree-list/.lift000-main: (tree) -> tree -cgen/specialize/tree-list/.lift000-main: (xs : list>) -> list> -cgen/specialize/tree-list/.mlift000-op: forall (tree, list>) -> list> -cgen/specialize/tree-list/.mlift000-op: forall (f : (a) -> b, xx : list>, tree) -> list> +cgen/specialize/tree-list/.lift000-main: (xs1219 : list>) -> list> +cgen/specialize/tree-list/.lift000-main: (xs1224 : list>) -> list> +cgen/specialize/tree-list/.mlift000-lift1232-mapT: forall (tree, list>) -> list> +cgen/specialize/tree-list/.mlift000-lift1232-mapT: forall (f : (a) -> b, xx1196 : list>, tree) -> list> cgen/specialize/tree-list/.mlift000-mapT: forall (a, list>) -> tree cgen/specialize/tree-list/.mlift000-mapT: forall (children0 : list>, f : (a) -> b, b) -> tree cgen/specialize/tree-list/children: forall (tree : tree) -> list> diff --git a/test/cgen/specialize/twostep-large.kk.out b/test/cgen/specialize/twostep-large.kk.out index a08034a13..9219ea60e 100644 --- a/test/cgen/specialize/twostep-large.kk.out +++ b/test/cgen/specialize/twostep-large.kk.out @@ -1,8 +1,9 @@ 75 75 -cgen/specialize/twostep-large/.lift000-main: (lo : int, hi : int) -> total list -cgen/specialize/twostep-large/.lift000-main: (lo0 : int, hi0 : int) -> total list +cgen/specialize/twostep-large/.lift000-main: () -> console () +cgen/specialize/twostep-large/.lift000-main: (lo267 : int, hi268 : int) -> total list +cgen/specialize/twostep-large/.lift000-main: (lo275 : int, hi276 : int) -> total list cgen/specialize/twostep-large/calls-large: (f : (int) -> total int) -> console () cgen/specialize/twostep-large/large: (f : (int) -> total int) -> total int cgen/specialize/twostep-large/main: () -> console () \ No newline at end of file diff --git a/test/cgen/specialize/twostep-large2.kk.out b/test/cgen/specialize/twostep-large2.kk.out index d85ebfeaa..e765709b7 100644 --- a/test/cgen/specialize/twostep-large2.kk.out +++ b/test/cgen/specialize/twostep-large2.kk.out @@ -1,26 +1,28 @@ 65000 65000 -cgen/specialize/twostep-large2/.lift000-repeatN: forall (f : () -> e a, lo : int, hi : int) -> e list -cgen/specialize/twostep-large2/.lift000-a: forall (f : () -> e a, lo : int, hi : int) -> e list -cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo : int, hi : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo0 : int, hi0 : int) -> total list> -cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo1 : int, hi1 : int) -> total list +cgen/specialize/twostep-large2/.lift000-repeatN: forall (f : () -> e a, lo477 : int, hi478 : int) -> e list +cgen/specialize/twostep-large2/.lift000-a: forall (f : () -> e a, lo485 : int, hi486 : int) -> e list +cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo493 : int, hi494 : int) -> total list>> +cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo501 : int, hi502 : int) -> total list> +cgen/specialize/twostep-large2/.lift000-large: (f : (int) -> total int, lo509 : int, hi510 : int) -> total list cgen/specialize/twostep-large2/.lift000-main: () -> console () cgen/specialize/twostep-large2/.lift000-main: () -> total int -cgen/specialize/twostep-large2/.lift000-main: (lo : int, hi : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-main: (lo0 : int, hi0 : int) -> total list> -cgen/specialize/twostep-large2/.lift000-main: (lo1 : int, hi1 : int) -> total list -cgen/specialize/twostep-large2/.lift000-main: (xs : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (lo535 : int, hi536 : int) -> total list>> +cgen/specialize/twostep-large2/.lift000-main: (lo543 : int, hi544 : int) -> total list> +cgen/specialize/twostep-large2/.lift000-main: (lo551 : int, hi552 : int) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs559 : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs564 : list) -> total list cgen/specialize/twostep-large2/.lift000-main: () -> total int -cgen/specialize/twostep-large2/.lift000-main: (lo2 : int, hi2 : int) -> total list>> -cgen/specialize/twostep-large2/.lift000-main: (lo3 : int, hi3 : int) -> total list> -cgen/specialize/twostep-large2/.lift000-main: (lo4 : int, hi4 : int) -> total list -cgen/specialize/twostep-large2/.lift000-main: (xs0 : list) -> total list -cgen/specialize/twostep-large2/.mlift000-op: forall (a, list) -> e list -cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi : int, a00.000 : int, a) -> e list -cgen/specialize/twostep-large2/.mlift000-op: forall (a, list) -> e list -cgen/specialize/twostep-large2/.mlift000-op: forall (f : () -> e a, hi : int, a00.000 : int, a) -> e list +cgen/specialize/twostep-large2/.lift000-main: (lo584 : int, hi585 : int) -> total list>> +cgen/specialize/twostep-large2/.lift000-main: (lo592 : int, hi593 : int) -> total list> +cgen/specialize/twostep-large2/.lift000-main: (lo600 : int, hi601 : int) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs608 : list) -> total list +cgen/specialize/twostep-large2/.lift000-main: (xs613 : list) -> total list +cgen/specialize/twostep-large2/.mlift000-lift620-repeatN: forall (a, list) -> e list +cgen/specialize/twostep-large2/.mlift000-lift620-repeatN: forall (f : () -> e a, hi478 : int, a00.000 : int, a) -> e list +cgen/specialize/twostep-large2/.mlift000-lift621-a: forall (a, list) -> e list +cgen/specialize/twostep-large2/.mlift000-lift621-a: forall (f : () -> e a, hi486 : int, a00.000 : int, a) -> e list cgen/specialize/twostep-large2/a: forall (i : int, f : () -> e a) -> e list cgen/specialize/twostep-large2/calls-large: (f : (int) -> total int) -> console () cgen/specialize/twostep-large2/large: (f : (int) -> total int) -> total int diff --git a/test/cgen/specialize/zipwithacc.kk.out b/test/cgen/specialize/zipwithacc.kk.out index 8fae7751e..283c2cf8a 100644 --- a/test/cgen/specialize/zipwithacc.kk.out +++ b/test/cgen/specialize/zipwithacc.kk.out @@ -1,6 +1,8 @@ [21,24,27,30,33,36,39,42,45,48] -cgen/specialize/zipwithacc/.lift000-main: (i : int, acc : list, xs0 : list, ys0 : list) -> console list -cgen/specialize/zipwithacc/.mlift000-zipwith-acc: forall (acc : list, f : (int, a, c) -> e b, i : int, xx : list, yy : list, b) -> e list +cgen/specialize/zipwithacc/.lift000-main: (i374 : int, acc375 : list, xs376 : list, ys377 : list) -> console list +cgen/specialize/zipwithacc/.mlift000-unroll261-zipwith-acc: forall (acc : list, f : (int, a, c) -> e b, i : int, xx : list, yy : list, b) -> + e list +cgen/specialize/zipwithacc/.unroll261-zipwith-acc: forall ((int, a, b) -> e c, int, list, list, list) -> e list cgen/specialize/zipwithacc/main: () -> console () cgen/specialize/zipwithacc/zipwith-acc: forall ((int, a, b) -> e c, int, list, list, list) -> e list \ No newline at end of file diff --git a/test/fip/README.md b/test/fip/README.md new file mode 100644 index 000000000..bcd3fc0d6 --- /dev/null +++ b/test/fip/README.md @@ -0,0 +1,236 @@ +# ICFP 2023 Paper Artifact: FP^2: Fully in-Place Functional Programming + +# Getting Started + +Go to the test directory: + +``` +# cd koka/test/fip +``` + +We will shorten this directory to `test#` in the guide. +This directory also contains this `README.md`. + +From this prompt, we can run our benchmarks as: + +``` +test# ./bench.sh rbtree run +``` +``` +~/home/dev/koka ~/home/dev/koka/test/fip +~/home/dev/koka/test/fip +using koka: /mnt/c/Users/daan/dev/koka/.stack-work/install/x86_64-linux-tinfo6/8f1dbd1b92c17da66792bc77d6f502c989021e266b5032fa +expanded benches: rbtree/rbtree-fip.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std-reuse.kk rbtree/rbtree-std.kk ... + +run kk__rbtree-fip__100000, iter 1, cmd: .koka/v2.4.1-bench/clang-release/rbtree-fip +total: 1000000 +elapsed: 0.60s, user: 0.59s, sys: 0.00s, rss: 6988kb + +... + +# benchmark variant param elapsed relative stddev rss +kk rbtree fip 100000 0.60 1.000 0 6988 +kk rbtree fip-icfp 100000 0.53 .883 0 6928 +kk rbtree std-reuse 100000 0.61 1.016 0 6940 +kk rbtree std 100000 1.53 2.550 0 7048 +kk rbtree fip-clrs 100000 0.78 1.300 0 7056 +c rbtree clrs 100000 0.68 1.133 0 6252 +c rbtree clrs-mi 100000 0.57 .950 0 8080 +c rbtree clrs-full 100000 0.68 1.133 0 6404 +c rbtree clrs-full-mi 100000 0.57 .950 0 8084 +cpp rbtree stl 100000 0.88 1.466 0 8528 +cpp rbtree stl-mi 100000 0.58 .966 0 10136 +``` + +This runs the `rbtree` benchmark on various variants +and eventually provides a summary in absolute runtimes (and rss), and normalized +runtimes relative to the Koka fip variant. + +Note that the precise results depend quite a bit on the host system, but the +relative performance should be similar (except when running in emulation). +The above results are on Ubuntu 22.0.4 with 16-core AMD 7950X @ 4.5Ghz. + + +# Step-by-step Guide + +## Run All Benchmarks + +The `../bench.kk` script runs each benchmark using `/usr/bin/time` to measure +the runtime and rss. For the benchmark figures in our paper we used +the following command: + +``` +test# ./bench.sh allb run -n=10 +``` + +to run all benchmarks 10 times for each available language, and use the median +of those runs (and calculate the standard error interval). + +The full expected results on an AMD7950X are at the bottom of this readme. +These should correspond closely to the results in Section 6 of the paper (Figure 10) +and support the conclusions drawn there. Note that the results can differ quite +bit among different systems, but if not running in emulation, the relative times +should be quite similar. + +Note: for convenience, the image contains the revised paper as +`fip-icfp23-submission.pdf` in the `~` directory. + + +## Benchmark Descriptions + +The benchmarks are described in detail in the paper. + +- `rbtree` : For 100 iterations: Create a red-black tree by successively inserting the integers 100_000 to 1. +- `ftree` : For 100 iterations: Create a finger-tree by successively snoc-ing the integers 100_000 to 1, + then uncons an element from the front and snoc it to the back 300_000 times. +- `msort` : Create a list of 100_000 random integers. For 100 iterations, run mergesort on this list. +- `qsort` : Create a list of 100_000 random integers. For 100 iterations, run quicksort on this list. +- `tmap` : Create a perfectly balanced tree of the integers 1 to 100_000. + For 1000 iterations: Create a copy of the _shared_ tree where each integer is increased by one. + +Each benchmark comes in different variants: + +- `fip`: A fully in-place algorithm. All as presented in the paper, + except for `rbtree` where we use the algorithm presented at ICFP'22 + on frame-limited reuse, and we add the algorithm from the paper as `rbtree-clrs`. +- `std-reuse`: The typical functional algorithm ... + - `rbtree` : as presented by Okasaki. + - `ftree` : as presented by Claessen. + - `msort` : as in Haskell's Data.List.sort + (with list reversal instead of closures in `ascending` to improve speed). + - `qsort`, `tmap` : the obvious, recursive implementation. +- `std`: Like `std-reuse` but compiled with `--fno-reuse`. +- C `std`: + - `rbtree`: A C implementation of the algorithm in Cormen et al. + - `tmap`: A C implementation using pointer reversal (corresponding to `fip`). +- C `std-mi`: As `std` but linked against the mimalloc allocator. +- C++ `stl`: The red-black tree in `std::map`. +- C++ `stl-mi`: As `stl-mi` but linked against the mimalloc allocator. + + +## Sources + +All the sources are in the `test/src` directories. For example: +``` +test# ls src/msort +msort-fip.kk msort-std.kk +``` + +The main implementation of the FIP check can be found in +`koka/src/Core/CheckFBIP.hs`, while the main Perceus +reuse analysis is in `koka/src/Backend/C/ParcReuse.hs`. + + +## Re-build the Benchmarks + +All tests can be recompiled using: +``` +test# ./bench.sh allb build +``` + +Further options: + +* `allb`: all benchmarks (also `allkk` and `allc` to select a subset, or `rbtree`, `msort`, `qsort`, `ftree`, and `tmap`). +* `build`: build benchmarks. +* `run`: run benchmarks and show benchmark scores (calculating median and stddev). +* `-n=<`N`>`: run each benchmark N times. +* `koka=`: set koka compiler command explicitly. +* `ccomp=`: set C compiler, either `clang` or `gcc` (or `gcc-`). + +The benchmarks are given the problem size `N` and run for `100_000_000/N` iterations. + + +## Expected Results + +These were obtained running on Ubuntu 22.0.4 on a 16-core AMD 7950X @ 4.5Ghz. + +``` +test# ./bench allb build run -n=10 +... +``` + +``` +# benchmark variant param elapsed relative stddev rss +kk rbtree fip 100000 0.59 1.000 .0057735 6944 +kk rbtree fip-icfp 100000 0.53 .898 .0051846 6916 +kk rbtree std-reuse 100000 0.61 1.033 .0059640 6900 +kk rbtree std 100000 1.48 2.508 .1023885 6936 +kk rbtree fip-clrs 100000 0.78 1.322 .0076325 6940 +c rbtree clrs 100000 0.68 1.152 .0066510 6368 +c rbtree clrs-mi 100000 0.57 .966 0 7944 +c rbtree clrs-full 100000 0.67 1.135 .0065529 6404 +c rbtree clrs-full-mi 100000 0.57 .966 0 7948 +cpp rbtree stl 100000 0.88 1.491 .0086082 8440 +cpp rbtree stl-mi 100000 0.58 .983 0 10168 +## +kk ftree fip 100000 0.83 1.000 .0057735 7036 +kk ftree std-reuse 100000 0.90 1.084 .075101 6912 +kk ftree std 100000 1.32 1.590 .0091798 6808 +## +kk msort fip 100000 0.92 1.000 .0057735 9064 +kk msort std-reuse 100000 0.90 .978 .0056464 11588 +kk msort std 100000 1.17 1.271 .01037767 11552 +## +kk qsort fip 100000 1.13 1.000 .0057735 14588 +kk qsort std-reuse 100000 1.48 1.309 .0226725 15140 +kk qsort std 100000 2.13 1.884 .0543863 15116 +## +kk tmap fip 100000 1.13 1.000 .0238048 11144 +kk tmap std-reuse 100000 0.80 .707 .00577263 11016 +kk tmap std 100000 0.82 .725 .0041857 11152 +c tmap fip 100000 1.36 1.203 .0208365 7968 +c tmap fip-mi 100000 0.59 .522 .0030137 9992 +c tmap std 100000 1.44 1.274 .0073554 7912 +c tmap std-mi 100000 0.63 .557 .0032158 9952 +``` + + +# Building from Scratch + +These are instructions to re-create the image on a Unix system. + +Basics: + +``` +sudo apt update +sudo apt ugrade +sudo apt-get install -y --no-install-recommends ca-certificates +sudo apt-get install -y --no-install-recommends libc-dev build-essential time bc +sudo apt-get install -y --no-install-recommends tar cmake curl +sudo apt-get install -y --no-install-recommends gcc clang +``` + +Stack: + +``` +curl -sSL https://get.haskellstack.org | sh +``` + +Mimalloc: + +``` +git clone https://github.com/microsoft/mimalloc -b v2.1.1 +cd mimalloc +mkdir -p out/release +cd out/release +cmake ../.. +make +sudo make install +cd ~ +``` + +Koka, commit 54a16a5 + +``` +git clone --recursive https://github.com/koka-lang/koka -b dev-fbip +cd koka +git checkout 54a16a5 +stack build --fast +``` + +And go to the test directory to build and run a benchmark: + +``` +cd ~/koka/test/fip +./bench.sh rbtree build run +``` diff --git a/test/fip/bench.sh b/test/fip/bench.sh new file mode 100755 index 000000000..2e41ce948 --- /dev/null +++ b/test/fip/bench.sh @@ -0,0 +1,527 @@ + +# +runparams="100000" # "1 10 100 1000 10000 100000 1000000" +runparams_small="1 10 100 1000" +benchmarks="rbtree ftree msort qsort tmap" +graphvariants="fip std-reuse std stl stl-mi std-mi" + +# note: order matters as it is made relative to the first +benches_tmapkk="tmap/tmap-fip.kk tmap/tmap-std.kk" +benches_tmapc="tmap/tmap-fip.c tmap/tmap-std.c" +benches_rbtreekk="rbtree/rbtree-fip.kk rbtree/rbtree-fip-icfp.kk rbtree/rbtree-std.kk rbtree/rbtree-fip-clrs.kk" +benches_rbtreec="rbtree/rbtree-clrs.c rbtree/rbtree-clrs-full.c rbtree/rbtree-stl.cpp" +benches_msortkk="msort/msort-fip.kk msort/msort-std.kk" +benches_qsortkk="qsort/qsort-fip.kk qsort/qsort-std.kk" +benches_ftreekk="ftree/ftree-fip.kk ftree/ftree-std.kk" + +benches_rbtree="$benches_rbtreekk $benches_rbtreec" +benches_msort="$benches_msortkk" +benches_qsort="$benches_qsortkk" +benches_tmap="$benches_tmapkk $benches_tmapc" +benches_ftree="$benches_ftreekk" +benches_all="$benches_rbtree $benches_ftree $benches_msort $benches_qsort $benches_tmap" + +# get this by running `stack path | grep local-install-root`` in the koka development directory +# koka_install_dir="/mnt/c/Users/daan/dev/koka/.stack-work/install/x86_64-linux-tinfo6/665c0f3ba306de11186f0f92ea0ca8305283b035f4fa2dfb5c2b12a96689073b/8.10.7" +# koka_install_dir="/Users/daan/dev/koka/.stack-work/install/aarch64-osx/b63e887d74237da23db5e39821e14b1f1662540a2b2d9c63219cb143bf61a966/8.10.7" +koka_install_dir="/Users/anton/orga/phd/koka/.stack-work/install/aarch64-osx/1a7c21de82e435443ed6a5394d51d0409374699330e76b45953b1b5661520371/8.10.7" + +# if kokainstall does not exist, try to find it from the local koka development directory +koka_dev_dir="../../../koka" + +if ! [ -d "$koka_install_dir" ]; then + if [ -d "$koka_dev_dir" ]; then + pushd "$koka_dev_dir" + koka_install_dir=`stack path | grep local-install-root` + koka_install_dir="${koka_install_dir#local-install-root: }" + popd + fi +fi + +koka="${koka_install_dir}/bin/koka" +koka_ver="v2.4.1" + +echo "using koka: $koka" + +coutdir=".koka/ccomp" +copts="-lpthread" + +cppoutdir=".koka/cppcomp" +cppopts="-lpthread" + +mimalloc_o="/usr/local/lib/mimalloc-2.1/mimalloc.o" + +gtime="/usr/bin/time" +if command -v "gtime"; then + gtime=`which gtime` +fi + +cppcomp="clang++" +ccomp="clang" +benches="" + +kkopts="" +benchdir="src" +verbose="no" + +do_build="no" +do_run="no" +do_avg="no" +do_graph="no" +max_runs=1 + +trap ctrl_c INT + +function ctrl_c() { + echo "Ctrl + C happened" + exit +} + +function ensure_dir { + if ! [ -d "$1" ]; then + mkdir -p "$1" + fi +} + +function info { + echo $1 +} + +function warning { + echo "" + echo "warning: $1" +} + +ensure_dir "log" +ensure_dir ".koka/ccomp" +ensure_dir ".koka/cppcomp" + +while : ; do + # set flag and flag_arg + flag="$1" + case "$flag" in + *=*) flag_arg="${flag#*=}" + flag="${flag%=*}";; + no-*) flag_arg="0" + flag="${flag#no-}";; + none) flag_arg="0" ;; + *) flag_arg="1" ;; + esac + case "$flag_arg" in + yes|on|true) flag_arg="1";; + no|off|false) flag_arg="0";; + esac + case "$flag" in + "") break;; + + allb) benches="$benches_all";; + + allkk) benches="$benches $benches_tmapkk $benches_rbtreekk $benches_fingerkk $benches_sortkk";; + allc) benches="$benches $benches_tmapc $benches_rbtreec";; + tmap) benches="$benches $benches_tmap";; + rbtree) benches="$benches $benches_rbtree";; + qsort) benches="$benches $benches_qsort";; + msort) benches="$benches $benches_msort";; + sort) benches="$benches $benches_msort $benches_qsort";; + ftree) benches="$benches $benches_ftree";; + tmap) benches="$benches $benches_tmapc";; + + + ccomp) ccomp="$flag_arg";; + cppcomp) cppcomp="$flag_arg";; + gcc) ccomp="gcc" + cppcomp="g++";; + clang) ccomp="clang" + cppcomp="clang++";; + + build) do_build="yes";; + run) do_run="yes" + do_avg="yes";; + graph) do_graph="yes";; + avg) do_avg="yes";; + + asm) kkopts="$kkopts --core --ccopts=-save-temps";; + core) kkopts="$kkopts --core";; + nounroll) kkopts="--fno-unroll";; + + koka) koka="$flag_arg";; + ocamlopt) ocamlopt="$flag_arg";; + + small) runparams="$runparams_small";; + + -n|-i) + max_runs=$flag_arg;; + + -v|--verbose) + verbose="yes";; + -h|--help|-\?|help|\?) + echo "./bench.sh [options]" + echo "" + echo "options:" + echo " -h, --help show this help" + echo " -v, --verbose be verbose (=$verbose)" + echo "" + echo "see 'bench.sh' for all available options" + echo "" + exit 0;; + *) warning "unknown option \"$1\"." 1>&2 + esac + shift +done + +# add -reuse to std, and -mi to c/cpp +function expand_benches { + local newb="" + for bench in $benches; do + local base=${bench%.*} + if [[ $bench == *-std\.kk ]]; then + newb="$newb $base-reuse.kk $bench" # order matters + elif [[ $bench == *\.c ]]; then + newb="$newb $bench $base-mi.c" + elif [[ $bench == *\.cpp ]]; then + newb="$newb $bench $base-mi.cpp" + else + newb="$newb $bench" + fi + done + benches=$newb + echo "expanded benches: $benches" +} + +expand_benches + +function build_kk { # + + local srcname="$1" + local base=${1%.*} # no ext + local stem=${base##*/} # dashed dir + local options="-O2 --no-debug --cc=$ccomp --buildtag=bench --buildname=$stem $kkopts" + if [[ $1 == *-std-reuse\.kk ]]; then + srcname="${1%-std-reuse.kk}-std.kk" + fi + if [[ $1 == *-std\.kk ]]; then + options="$options --fno-reuse" + fi + if ! [ -f "$benchdir/$srcname" ]; then + info "SKIP $bench ($benchdir/$srcname) -- not found" + else + local cmd="$koka $options -i$benchdir $benchdir/$srcname" + info "" + info "build: $1: $cmd" + $cmd + # "$koka" $options -i$benchdir $benchdir/$srcname + fi +} + +function build_c { # + local srcname="$1" + local base=${1%.*} + local stem=${base##*/} + local options="-O3 -o $coutdir/$stem $copts" + if [[ $(uname -m) == 'arm64' ]]; then + options="$options -mcpu=apple-m1" + else + options="$options -march=native" + fi + if [[ "$1" == *"-mi"* ]]; then + options="$options $mimalloc_o -I ${mimalloc_usr_local}include/$mimalloc" + srcname="${1%-mi.c}.c" + fi + if ! [ -f "$benchdir/$srcname" ]; then + info "SKIP $bench ($benchdir/$srcname) -- not found" + else + local cmd="$ccomp $options $benchdir/$srcname" + info "" + info "build: $1: $cmd" + $cmd + fi +} + +function build_cpp { # + local srcname="$1" + local base=${1%.*} + local stem=${base##*/} + local options="--std=c++17 -O3 -o $cppoutdir/$stem $cppopts" + if [[ $(uname -m) == 'arm64' ]]; then + options="$options -mcpu=apple-m1" + else + options="$options -march=native" + fi + if [[ "$1" == *"-mi"* ]]; then + options="$options $mimalloc_o -I ${mimalloc_usr_local}include/$mimalloc" + srcname="${1%-mi.cpp}.cpp" + fi + if ! [ -f "$benchdir/$srcname" ]; then + info "SKIP $bench ($benchdir/$srcname) -- not found" + else + local cmd="$cppcomp $options $benchdir/$srcname" + info "" + info "build: $1: $cmd" + $cmd + fi +} + +function build_all { + for bench in $benches; do + if [[ $bench == *\.kk ]]; then + build_kk $bench $ccomp + elif [[ $bench == *\.c ]]; then + build_c $bench + elif [[ $bench == *\.cpp ]]; then + build_cpp $bench + else + warning "define build compiler for $bench" + fi + done +} + +function run { #label cmd runidx log runparam + info "" + info "run $1, iter $3, cmd: $2" + local logrun="./log/run.txt" + $gtime -o $logrun -f "elapsed: %es, user: %Us, sys: %Ss, rss: %Mkb" $2 $5 + cat $logrun + # extract elapsed time + local line=`head -1 $logrun` + local elapsed=${line#elapsed: } + elapsed=${elapsed/s,*/} + local rss=${line#*rss: } + rss=${rss/kb*/} + echo "$elapsed $rss" >> "$4" +} + +function run_all { + for bench in $benches; do + local exe="" + local prefix=${bench#*\.} + local base=${bench%\.*} # no extension + local stem=${base##*/} # no directory + + if [[ $bench == *\.kk ]]; then + exe=".koka/${koka_ver}-bench/$ccomp-release/$stem" + elif [[ $bench == *\.c ]]; then + exe=".koka/ccomp/$stem" + elif [[ $bench == *\.cpp ]]; then + exe=".koka/cppcomp/$stem" + fi + + local cmd="$exe" + if ! [ -f $exe ]; then + info "bench $stem: NA (exe not found: $exe)" + elif [ -z $cmd ]; then + info "bench $rtem: NA (no command)" # define for ML + else + for runparam in $runparams; do + local bname="${prefix}__${stem}__$runparam" + local log="./log/$bname.txt" + rm -f $log 2> /dev/null + for ((runs=1; runs<=$max_runs; runs++)); do + run $bname $cmd $runs $log $runparam + done + done + fi + done +} + + +basetime="" + +function avg { #$1=bname $2=log $3=logbench $4= $5=benchname $6= $7= + local median="0.01" + local stddev="0" + local rss="0" + if [ -f "$2" ]; then + local median=`sort -n $2 | awk ' { a[i++]=$1; } END { x=int((i+1)/2); if (x < (i+1)/2) print (a[x-1]+a[x])/2; else print a[x-1]; }'` + if [ "$median" = "0" ]; then + median="0.01" + fi + local stddev=`awk ' { sqrsum += ($1 - '"$median"')^2; } END { print sqrt(sqrsum/NR); }' < $2` + local rss=`sort -n $2 | awk ' { a[i++]=$2; } END { x=int((i+1)/2); if (x < (i+1)/2) print (a[x-1]+a[x])/2; else print a[x-1]; }'` + if [ "$basetime" = "" ]; then + basetime="$median" + fi + fi + local rmedian=`echo "scale=3; $median / $basetime" | bc` + local rstddev=`echo "scale=3; $rmedian * $stddev" | bc` + if [[ $median == Command* ]]; then + # echo "$1 NA NA NA NA (out of stack)" >> $3 + echo "$4 $5 $6 $7 NA 0.1 0 0.1" >> $3 + else + # echo "$1 ${median}s ${rmedian}x ${rstddev} ${rss}kb" >> $3 + echo "$4 $5 $6 $7 ${median} ${rmedian} ${rstddev} ${rss}" >> $3 + fi +} + +function avg_all { + local logbench="./log/avg.txt" + rm -f $logbench 2> /dev/null + echo "# benchmark variant param elapsed relative stddev rss" >> $logbench + for benchmark in $benchmarks; do + for runparam in $runparams; do + basetime="" + for bench in $benches; do + local prefix=${bench#*\.} + local base=${bench%\.*} # no extension + local stem=${base##*/} + # local bdir=$(echo $base | cut -d'/' -f 1) + local variant=${stem#*-} + local bname=${stem%%-*} + local label="${prefix}__${stem}__${runparam}" + local log="./log/$label.txt" + if [ "$benchmark" = "$bname" ]; then + avg $label $log $logbench $prefix $bname $variant $runparam + fi + done + echo "##" >> $logbench + done + echo "" >> $logbench + done + echo "" + column -t $logbench +} + + + +#------------------------------------- +# graph with the x ticks for each runparam + +function xgraph_variant { # map + # $1 $2 $3 $4 $5 $6 $7 $8 $9 + # log entry: kk map trmc 1000 + awk ' + BEGIN { + prefix="'"$1"'" + bench="'"$2"'" + variant="'"$3"'" + varianttexname="'"$4"'" + print "\\pgfplotstableread{" + print "x y y-error meta" + } + $1==prefix && $2==bench && $3==variant { + if ($1 == "kk" && $3 == "trmc") { + printf( "%i %0.3f %0.3f {\\absnormlabel{%0.2f}}\n", i++, $6, $7, $5 ); + } + else if ($6 == 0.1) { + printf( "%i 0.100 0.000 {\\!\\!out of stack}\n", i++); + } + else { + printf( "%i %0.3f %0.3f {\\normlabel{%0.2f}}\n", i++, ($6>3 ? 3 : $6), $7, $6); + } + } + END { + print "}\\datatime" prefix bench varianttexname + print " " + } + ' $5 >> $6 +} + +function xgraph_all { + local logbench="./log/avg.txt" + local texdata="./log/graph.tex" + echo "\\pgfplotsset{" > $texdata + echo " xticklabels = {" >> $texdata + #local benchname="" + #for bench in $benches; do + # local bbench=${bench#*\/} # no directory + # benchname=${bbench%\_*} + # break + #done + for runparam in $runparams; do + local lab="$runparam" + if [ "$lab" = "10000" ]; then + lab="10\\nsep 000" + elif [ "$lab" = "100000" ]; then + lab="100\\nsep 000" + elif [ "$lab" = "1000000" ]; then + lab="1\\nsep 000\\nsep 000" + fi + echo " \\strut $lab," >> $texdata + done + echo "}}" >> $texdata + echo " " >> $texdata + for bench in $benches; do + local prefix=${bench#*\.} + local base=${bench%\.*} # no extension + local stem=${base##*\/} # no directory + local variant=${stem#*-} + local varianttexname="${variant//-/x/}" + local benchname=${stem%%-*} + echo "GRAPH $benchname, $variant" + xgraph_variant $prefix $benchname $variant $varianttexname $logbench $texdata + done + cat $texdata +} + + +#-------------------------------------- +# graph with xtick each benchmark + + +function graph_variant { # $1= $2= $3= $4= $5= + # + # $1 $2 $3 $4 $5 $6 $7 $8 $9 + # log entry: kk map trmc 1000 + awk ' + BEGIN { + prefix="'"$1"'" + variant="'"$2"'" + varianttexname="'"$3"'" + print "\\pgfplotstableread{" + print "x y y-error meta" + } + $1==prefix && $3==variant { + if ($1 == "kk" && $3 == "fip") { + printf( "%i %0.3f %0.3f {\\absnormlabel{%0.2f}}\n", i++, $6, $7, $5 ); + } + else if ($6 == 0.1) { + printf( "%i 0.100 0.000 {\\!\\!out of stack}\n", i++); + } + else { + printf( "%i %0.3f %0.3f {\\normlabel{%0.2f}}\n", i++, ($6>3 ? 3 : $6), $7, $6); + } + } + END { + print "}\\datatime" prefix varianttexname + print " " + } + ' $4 >> $5 +} + +function graph_all { + local logbench="./log/avg.txt" + local texdata="./log/graph.tex" + + echo "\\pgfplotsset{" > $texdata + echo " xticklabels = {" >> $texdata + for benchmark in $benchmarks; do + echo " \\strut $benchmark," >> $texdata + done + echo "}}" >> $texdata + echo " " >> $texdata + + for variant in $graphvariants; do + local varianttexname="${variant//-/}" + graph_variant "kk" $variant $varianttexname $logbench $texdata + # graph_variant "cpp" $variant $varianttexname $logbench $texdata + graph_variant "c" $variant $varianttexname $logbench $texdata + done + cat $texdata +} + + +if [ "$do_build" = "yes" ]; then + build_all +fi + +if [ "$do_run" = "yes" ]; then + run_all +fi + +if [ "$do_avg" = "yes" ]; then + avg_all +fi + +if [ "$do_graph" = "yes" ]; then + graph_all + #xgraph_all +fi diff --git a/test/fip/src/ftree/ftree-fip.kk b/test/fip/src/ftree/ftree-fip.kk new file mode 100644 index 000000000..be025f0a0 --- /dev/null +++ b/test/fip/src/ftree/ftree-fip.kk @@ -0,0 +1,283 @@ +// Adapted from "Finger Trees Explained Anew, and Slightly Simplified (Functional Pearl)", Claessen +import std/num/int32 +import std/os/env + +ref type pad + Pad + +type reuse3 + Reuse3(a : pad, b : pad, c : pad) + +type afew + One(a : a, b : pad, c : pad) + Two(a : a, b : a, c : pad) + Three(a : a, b : a, c : a) + +type tuple + Pair(a : a, b : a, c : pad) + Triple(a : a, b : a, c : a) + +type seq + Empty + Unit(a : a, b : pad, c : pad) + More0(l : a, s : seq>, r : afew) + More(l : tuple, s : seq>, r : afew) + +type buffer + BNil + BCons(next : buffer, b : pad, c : pad) + +value type bseq + BSeq(s : seq, q : buffer) + +// Isomorphic to (,,,) but unboxed +value type tuple4 + Tuple4(fst:a,snd:b,thd:c,field4:d) + +fun bhead(^bs : bseq) : exn a + match bs + BSeq(s, _) -> head(s) + +fun head(^s : seq) : exn a + match s + Unit(x) -> x + More0(x, _, _) -> x + More(Pair(x, _, _), _, _) -> x + More(Triple(x, _, _), _, _) -> x + +fip fun bcons(x : a, u3 : reuse3, bs : bseq) : exn bseq + val BSeq(s, b) = bs + val (s', b') = cons(x, u3, s, b) + BSeq(s', b') + +fip fun cons(x : a, u3 : reuse3, s : seq, b : buffer) : exn (seq, buffer) + match s + Empty -> (Unit(x, Pad, Pad), b) + Unit(y, _, _) -> (More0(x, Empty, One(y, Pad, Pad)), b) + More0(y, q, u) -> (More(Pair(x, y, Pad), q, u), b) + More(Pair(y, z, _), q, u) -> + (More(Triple(x, y, z), q, u), BCons(b, Pad, Pad)) + More(Triple(y, z, w), q, u) -> + val BCons(b', _, _) = b + val (q', b'') = cons(Pair(z, w, Pad), u3, q, b') + (More(Pair(x, y, Pad), q', u), b'') + +fip fun buncons(bs : bseq) : exn (a, reuse3, bseq) + val BSeq(s, b) = bs + val Tuple4(x, u3, s', b') = uncons(s, b) + (x, u3, BSeq(s', b')) + +fip fun uncons(s : seq, b : buffer) : exn tuple4, buffer> + match s + Unit(x, _, _) -> + Tuple4(x, Reuse3(Pad,Pad,Pad), Empty, b) + More(Triple(x, y, z), q, u) -> + val BCons(b', _, _) = b + Tuple4(x, Reuse3(Pad,Pad,Pad), More(Pair(y, z, Pad), q, u), b') + More(Pair(x, y, _), q, u) -> + Tuple4(x, Reuse3(Pad,Pad,Pad), More0(y, q, u), b) + More0(x, q, u) -> + val (q', b') = more0(q, u, b) + Tuple4(x, Reuse3(Pad,Pad,Pad), q', b') + +fip fun more0(q : seq>, u : afew, b : buffer) : exn (seq, buffer) + match q + Empty -> + match u + One(x, y, z) -> (Unit(x, y, z), b) + Two(y, z, _) -> + val BCons(b', _, _) = b + (More0(y, Empty, One(z, Pad, Pad)), b') + Three(y, z, w) -> + val BCons(b', _, _) = b + (More0(y, Empty, Two(z, w, Pad)), b') + Unit(p, _, _) -> + match p + Pair(x, y, _) -> (More(Pair(x, y, Pad), Empty, u), b) + Triple(x, y, z) -> + val BCons(b', _, _) = b + (More0(x, Unit(Pair(y,z,Pad),Pad,Pad), u), b') + More0(p, q1, u1) -> + match p + Pair(x, y) -> + val (q1', b') = more0(q1, u1, b) + (More(Pair(x, y, Pad), q1', u), b') + Triple(x, y, z) -> + val BCons(b', _, _) = b + (More0(x, More0(Pair(y,z,Pad), q1, u1), u), b') + More(Pair(p, y1), q1, u1) -> + match p + Pair(x, y) -> (More(Pair(x, y, Pad), More0(y1, q1, u1), u), b) + Triple(x, y, z) -> + val BCons(b', _, _) = b + (More0(x, More(Pair(Pair(y,z,Pad), y1, Pad), q1, u1), u), b') + More(Triple(p, y1, z1), q1, u1) -> + val BCons(b', _, _) = b + match p + Pair(x, y) -> + (More(Pair(x, y, Pad), More(Pair(y1, z1, Pad), q1, u1), u), b') + Triple(x, y, z) -> + (More0(x, More(Triple(Pair(y,z,Pad), y1, z1), q1, u1), u), b') + +fip fun bsnoc(bs : bseq, u3 : reuse3, x : a) : exn bseq + val BSeq(s, b) = bs + val (s', b') = snoc(s, b, u3, x) + BSeq(s', b') + +fip fun snoc(s : seq, b : buffer, u3 : reuse3, x : a) : exn (seq, buffer) + match s + Empty -> (Unit(x, Pad, Pad), b) + Unit(y, _, _) -> (More0(y, Empty, One(x, Pad, Pad)), b) + More0(u, q, One(y, _, _)) -> (More0(u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) + More (u, q, One(y, _, _)) -> (More (u, q, Two(y, x, Pad)), BCons(b, Pad, Pad)) + More0(u, q, Two(y, z, _)) -> (More0(u, q, Three(y, z, x)), BCons(b, Pad, Pad)) + More (u, q, Two(y, z, _)) -> (More (u, q, Three(y, z, x)), BCons(b, Pad, Pad)) + More0(u, q, Three(y, z, w)) -> + val BCons(b', _, _) = b + val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) + (More0(u, q', Two(w, x, Pad)), b'') + More(u, q, Three(y, z, w)) -> + val BCons(b', _, _) = b + val (q', b'') = snoc(q, b', u3, Pair(y, z, Pad)) + (More(u, q', Two(w, x, Pad)), b'') + +// append + +type list3 + Cons3(x : a, xx : list3, c : pad) + Nil3 + +fip fun reverse3(xs : list3) : list3 + reverse-append3( xs, Nil3 ) + +fip fun reverse-acc(acc : list3, ys : list3 ) : list3 + match ys + Cons3(x,xx,pad) -> reverse-acc(Cons3(x,acc,pad),xx) + _ -> acc + +fip fun reverse-append3( xs : list3, tl : list3 ) : list3 + reverse-acc(tl,xs) + +fip fun (++)(xs : list3, ys : list3 ) : list3 + append3(xs, ys) + +fip fun append3(xs : list3, ys : list3 ) : list3 + match xs + Cons3(x,xx,pad) -> Cons3(x,append3(xx,ys),pad) + Nil3 -> ys + +fip fun foldl3(xs,z1,z2,^f) + match xs + Cons3(x,xx) -> + val (z1', z2') = f(z1,z2,Reuse3(Pad,Pad,Pad),x) + foldl3(xx,z1',z2',f) + Nil3 -> (z1,z2) + +// foldl3 specialized to the `flip` function +fip fun foldl3_flipped(xs,z1,z2,^f) + match xs + Cons3(x,xx) -> + val (z1', z2') = f(x,Reuse3(Pad,Pad,Pad),z1,z2) + foldl3_flipped(xx,z1',z2',f) + Nil3 -> (z1,z2) + +fip fun foldr3(xs,z1,z2,^f) + xs.reverse3.foldl3_flipped(z1,z2,f) + +fip fun (++)( xs : buffer, ys : buffer ) : buffer + append-buffers(xs, ys) + +fip fun append-buffers(b1 : buffer, b2 : buffer) : buffer + match b1 + BNil -> b2 + BCons(b', _, _) -> BCons(append-buffers(b', b2), Pad, Pad) + +fip fun afew-to-list(u : afew, b : buffer) : exn (list3, buffer) + match u + One(x) -> (Cons3(x, Nil3, Pad), b) + Two(x,y) -> + match b + BCons(b', _, _) -> (Cons3(x, Cons3(y, Nil3, Pad), Pad), b') + Three(x,y,z) -> + match b + BCons(BCons(b', _, _), _, _) -> + (Cons3(x, Cons3(y, Cons3(z, Nil3, Pad), Pad), Pad), b') + +fip fun tuple-to-list(u : tuple, b : buffer) : exn (list3, buffer) + match u + Pair(x,y) -> + match b + BCons(b', _, _) -> (Cons3(x, Cons3(y, Nil3, Pad), Pad), b') + Triple(x,y,z) -> + match b + BCons(BCons(b', _, _), _, _) -> + (Cons3(x, Cons3(y, Cons3(z, Nil3, Pad), Pad), Pad), b') + +fip fun to-tuples(xs : list3, b : buffer) : (list3>, buffer) + match xs + Cons3(x, Cons3(y, Nil3)) -> + (Cons3(Pair(x,y,Pad), Nil3, Pad), b) + Cons3(x, Cons3(y, Cons3(z, Cons3(w, Nil3)))) -> + (Cons3(Pair(x,y,Pad), Cons3(Pair(z,w,Pad),Nil3,Pad), Pad), b) + Cons3(x, Cons3(y, Cons3(z, xs))) -> + val (xs', b') = to-tuples(xs, b) + (Cons3(Triple(x,y,z), xs', Pad), BCons(b', Pad, Pad)) + _ -> (Nil3, b) // only if xs == Nil3 + +fip fun append(q1 : bseq, q2 : bseq) : pure bseq + match (q1, q2) + (BSeq(q1, b1), BSeq(q2, b2)) -> + val (q, b) = glue(q1, b1, Nil3, BNil, q2, b2) + BSeq(q, b) + +fip fun glue(q1 : seq, b1 : buffer, xs : list3, bs0 : buffer, q2 : seq, b2 : buffer) : pure (seq, buffer) + match(q1, q2) + (Empty, q2) -> xs.foldr3(q2, (bs0 ++ b1 ++ b2), cons) + (q1, Empty) -> xs.foldl3(q1, (bs0 ++ b2 ++ b1), snoc) + (Unit(x,_,_), q2) -> (Cons3(x,xs,Pad)).foldr3(q2, (bs0 ++ b1 ++ b2), cons) + (q1, Unit(x,_,_)) -> append3(xs,Cons3(x,Nil3,Pad)).foldl3(q1, (bs0 ++ b2 ++ b1), snoc) + (More(u1, q1, v1), More(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, BCons(bs0, Pad, Pad)) + val (u2', bs2) = tuple-to-list(u2, bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More(u1, q, v2), b) + (More0(u1, q1, v1), More(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, BCons(bs0, Pad, Pad)) + val (u2', bs2) = tuple-to-list(u2, bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More0(u1, q, v2), b) + (More(u1, q1, v1), More0(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, bs0) + val (u2', bs2) = (Cons3(u2, Nil3, Pad), bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More(u1, q, v2), b) + (More0(u1, q1, v1), More0(u2, q2, v2)) -> + val (v1', bs1) = afew-to-list(v1, bs0) + val (u2', bs2) = (Cons3(u2, Nil3, Pad), bs1) + val (ts, bs3) = to-tuples(v1' ++ xs ++ u2', bs2) + val (q, b) = glue(q1, b1, ts, bs3, q2, b2) + (More0(u1, q, v2), b) + +// benchmark + +fun iterate(s : bseq, n : int32) : bseq + if n <= 0.int32 then s + else + val (x, u3, s') = buncons(s) + iterate(bsnoc(s', u3, x), n - 1.int32) + +fun build(n : int32, s : bseq) : bseq + if n <= 0.int32 then s else build(n - 1.int32, bsnoc(s, Reuse3(Pad,Pad,Pad), n)) + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val s = build(n, BSeq(Empty, BNil)) + acc + bhead(iterate(s, n * 3.int32)) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/ftree/ftree-std.kk b/test/fip/src/ftree/ftree-std.kk new file mode 100644 index 000000000..bcfbfd7e8 --- /dev/null +++ b/test/fip/src/ftree/ftree-std.kk @@ -0,0 +1,112 @@ +// Adapted from "Finger Trees Explained Anew, and Slightly Simplified (Functional Pearl)", Claessen +import std/num/int32 +import std/os/env + +// Originally "some" which is a reserved keyword in Koka +type afew + One(a : a) + Two(a : a, b : a) + Three(a : a, b : a, c : a) + +type tuple + Pair(a : a, b : a) + Triple(a : a, b : a, c : a) + +type seq + Empty // Nil is used for the empty list in Koka + Unit(a : a) + More(l : afew, s : seq>, r : afew) + +fun head(s : seq) : a + match s + Unit(x) -> x + More(One(x), _, _) -> x + More(Two(x, _), _, _) -> x + More(Three(x, _, _), _, _) -> x + +fun cons(x : a, s : seq) : seq + match s + Empty -> Unit(x) + Unit(y) -> More(One(x), Empty, One(y)) + More(One(y), q, u) -> More(Two(x, y), q, u) + More(Two(y, z), q, u) -> More(Three(x, y, z), q, u) + More(Three(y, z, w), q, u) -> More(Two(x, y), cons(Pair(z, w), q), u) + +fun uncons(s : seq) : (a, seq) + match s + Unit(x) -> (x, Empty) + More(Three(x, y, z), q, u) -> (x, More(Two(y, z), q, u)) + More(Two(x, y), q, u) -> (x, More(One(y), q, u)) + More(One(x), q, u) -> (x, more0(q, u)) + +// we inline chop and map1 for better reuse behaviour +fun more0(q : seq>, u : afew) : seq + match q + Empty -> match u + One(y) -> Unit(y) + Two(y, z) -> More(One(y), Empty, One(z)) + Three(y, z, w) -> More(One(y), Empty, Two(z, w)) + Unit(p) -> match p + Pair(x, y) -> More(Two(x, y), Empty, u) + Triple(x, y, z) -> More(One(x), Unit(Pair(y,z)), u) + More(One(p), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), more0(q1, u1), u) + Triple(x, y, z) -> More(One(x), More(One(Pair(y,z)), q1, u1), u) + More(Two(p, y1), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), More(One(y1), q1, u1), u) + Triple(x, y, z) -> More(One(x), More(Two(Pair(y,z), y1), q1, u1), u) + More(Three(p, y1, z1), q1, u1) -> match p + Pair(x, y) -> More(Two(x, y), More(Two(y1, z1), q1, u1), u) + Triple(x, y, z) -> More(One(x), More(Three(Pair(y,z), y1, z1), q1, u1), u) + +fun snoc(s : seq, x : a) : seq + match s + Empty -> Unit(x) + Unit(y) -> More(One(y), Empty, One(x)) + More(u, q, One(y)) -> More(u, q, Two(y, x)) + More(u, q, Two(y, z)) -> More(u, q, Three(y, z, x)) + More(u, q, Three(y, z, w)) -> More(u, snoc(q, Pair(y, z)), Two(w, x)) + +fun to-list(u : afew) : list + match u + One(x) -> [x] + Two(x,y) -> [x,y] + Three(x,y,z) -> [x,y,z] + +fun to-tuples(xs : list) : list> + match xs + Cons(x, Cons(y, Nil)) -> [Pair(x,y)] + Cons(x, Cons(y, Cons(z, Cons(w, Nil)))) -> [Pair(x,y), Pair(z,w)] + Cons(x, Cons(y, Cons(z, xs))) -> Cons(Triple(x,y,z), to-tuples(xs)) + _ -> [] // only if xs == Nil + +fun append(q1 : seq, q2 : seq) :
seq + glue(q1, Nil, q2) + +fun glue(q1 : seq, xs : list, q2 : seq) :
seq + match(q1, q2) + (Empty, _) -> xs.foldr(q2, cons) + (_, Empty) -> xs.foldl(q1, snoc) + (Unit(x), _) -> (Cons(x,xs)).foldr(q2, cons) + (_, Unit(x)) -> (xs ++ [x]).foldl(q1, snoc) + (More(u1, q1, v1), More(u2, q2, v2)) -> + More(u1, glue(q1, to-tuples(to-list(v1) ++ xs ++ to-list(u2)), q2), v2) + +fun iterate(s : seq, n : int32) : seq + if n <= 0.int32 then s + else + val (x, s') = uncons(s) + iterate(snoc(s', x), n - 1.int32) + +fun build(n : int32, s : seq) :
seq + if n <= 0.int32 then s else build(n - 1.int32, snoc(s, n)) + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val s = build(n, Empty) + acc + head(iterate(s, n * 3.int32)) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/msort/msort-fip.kk b/test/fip/src/msort/msort-fip.kk new file mode 100644 index 000000000..452148d73 --- /dev/null +++ b/test/fip/src/msort/msort-fip.kk @@ -0,0 +1,133 @@ +// Haskell's Data.List.sort function ported to Koka +import std/num/int32 +import std/os/env + +alias elem = int32 + +ref type pad + Pad + +type unit2 + Unit2(a : pad, b : pad) + +type pair + Pair(a : a, b : a) + +type sublist + SCons(a : a, cs : sublist) + STuple(a : a, b : a) + +type partition + Sublist(c : sublist, z : partition) + Singleton(c : a, z : partition) + End + +fip fun reverse-go(c : sublist, acc : sublist, u : unit2) : sublist + match c + SCons(a, cs) -> reverse-go(cs, SCons(a, acc), u) + STuple(a, b) -> SCons(b, SCons(a, acc)) + +fip fun reverse-sublist(c : sublist) : sublist + match c + SCons(a, SCons(b, c)) -> reverse-go(c, STuple(b, a), Unit2(Pad,Pad)) + SCons(a, STuple(b, c)) -> SCons(c, STuple(b, a)) + STuple(a, b) -> STuple(b, a) + +fip fun sequences(xs : list) : div partition + match(xs) + Cons(a, Cons(b, xs1)) -> if(a > b) + then + val (sublist, bs) = descending(b, STuple(b, a), xs1) + Sublist(sublist, sequences(bs)) + else + val (sublist, bs) = ascending(b, STuple(b, a), xs1) + Sublist(sublist, sequences(bs)) + Cons(a, Nil) -> Singleton(a, End) + Nil -> End + +fip fun descending(a : elem, sublist : sublist, bs : list) : (sublist, list) + match(bs) + Cons(b, bs1) | a > b -> descending(b, SCons(b, sublist), bs1) + bs -> (sublist, bs) + +fip fun ascending(a : elem, sublist : sublist, bs : list) : (sublist, list) + match(bs) + Cons(b, bs1) | (a <= b) -> ascending(b, SCons(b, sublist), bs1) + bs -> (reverse-sublist(sublist), bs) + +fip fun to-list(c : sublist, u : unit2) : list + match c + SCons(a, cs) -> Cons(a, to-list(cs, u)) + STuple(a, b) -> Cons(a, Cons(b, Nil)) + +fip fun merge-all(xs : partition) :
list + match(xs) + Sublist(x, End) -> to-list(x, Unit2(Pad,Pad)) + Singleton(x, End) -> Cons(x, Nil) + xs -> merge-all(merge-pairs(xs)) + +fip fun merge-pairs(xs : partition) :
partition + match(xs) + Sublist(a, Sublist(b, xs1)) -> Sublist(merge(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Sublist(a, Singleton(b, xs1)) -> Sublist(merge-last-left(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Singleton(a, Sublist(b, xs1)) -> Sublist(merge-last-right(a, b, Unit2(Pad,Pad)), merge-pairs(xs1)) + Singleton(a, Singleton(b, xs1)) -> + Sublist(if a <= b then STuple(a, b) else STuple(b, a), merge-pairs(xs1)) + xs -> xs + +fip fun merge(c1 : sublist, c2 : sublist, u : unit2) :
sublist + match c1 + SCons(a, cs1) -> match c2 + SCons(b, cs2) -> + if a <= b then SCons(a, merge(cs1, SCons(b, cs2), u)) + else SCons(b, merge(SCons(a, cs1), cs2, u)) + STuple(b, c) -> + if a <= b then SCons(a, merge(cs1, STuple(b, c), u)) + else SCons(b, merge-last-left(SCons(a, cs1), c, u)) + STuple(a, b) -> match c2 + SCons(c, cs2) -> + if a <= c then SCons(a, merge-last-right(b, SCons(c, cs2), u)) + else SCons(c, merge(STuple(a, b), cs2, u)) + STuple(c, d) -> + if a <= c then SCons(a, merge-right(b, Pair(c, d), u)) + else SCons(c, merge-left(Pair(a, b), d, u)) + +fip fun merge-last-right(a : elem, c2 : sublist, u : unit2) : sublist + match c2 + SCons(b, cs2) -> if a <= b then SCons(a, SCons(b, cs2)) + else SCons(b, merge-last-right(a, cs2, u)) + STuple(b, c) -> merge-right(a, Pair(b, c), u) + +fip fun merge-last-left(c2 : sublist, d : elem, u : unit2) : sublist + match c2 + SCons(a, cs2) -> if a <= d then SCons(a, merge-last-left(cs2, d, u)) + else SCons(d, SCons(a, cs2)) + STuple(a, b) -> merge-left(Pair(a, b), d, u) + +fip fun merge-right(a : elem, p : pair, u : unit2) : sublist + match p + Pair(b, c) -> if a <= b then SCons(a, STuple(b, c)) + else SCons(b, if a <= c then STuple(a, c) else STuple(c, a)) + +fip fun merge-left(p : pair, d : elem, u : unit2) : sublist + match p + Pair(a, b) -> if a <= d then SCons(a, if b <= d then STuple(b, d) else STuple(d, b)) + else SCons(d, STuple(a, b)) + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = merge-all(sequences(xs)) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/msort/msort-std.kk b/test/fip/src/msort/msort-std.kk new file mode 100644 index 000000000..9fcb70ca7 --- /dev/null +++ b/test/fip/src/msort/msort-std.kk @@ -0,0 +1,58 @@ +// Haskell's Data.List.sort function ported to Koka +import std/num/int32 +import std/os/env + +alias elem = int32 + +fun sequences(xs : list) :
list> + match(xs) + Cons(a, Cons(b, xs1)) -> + if(a > b) then descending(b, Cons(a, Nil), xs1) + else ascending(b, Cons(a, Nil), xs1) + _ -> Cons(xs, Nil) + +fun descending(a : elem, chain : list, bs : list) :
list> + match(bs) + Cons(b, bs1) | a > b -> descending(b, Cons(a, chain), bs1) + _ -> Cons(Cons(a, chain), sequences(bs)) + +fun ascending(a : elem, chain : list, bs : list) :
list> + match(bs) + Cons(b, bs1) | (a <= b) -> ascending(b, Cons(a, chain), bs1) + _ -> Cons(reverse(Cons(a, chain)), sequences(bs)) + +fun merge-all(xs : list>) :
list + match xs + Cons(x, Nil) -> x + _ -> merge-all(merge-pairs(xs)) + +fun merge-pairs(xs : list>) :
list> + match xs + Cons(a, Cons(b, xx)) -> Cons(merge(a, b), merge-pairs(xx)) + _ -> xs + +fun merge(xs : list, ys : list) :
list + match(xs, ys) + (Cons(x, xx), Cons(y, yy)) -> + if(x > y) then Cons(y, merge(xs, yy)) + else Cons(x, merge(xx, ys)) + (Cons(_, _), Nil) -> xs + (_, _) -> ys + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = merge-all(sequences(xs)) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/qsort/qsort-fip.kk b/test/fip/src/qsort/qsort-fip.kk new file mode 100644 index 000000000..1a6e61213 --- /dev/null +++ b/test/fip/src/qsort/qsort-fip.kk @@ -0,0 +1,97 @@ +import std/num/int32 +import std/os/env + +alias elem = int32 + +ref type pad + Pad + +ref type unit2 + Unit2(a : pad, b : pad) + +type maybe2 + Nothing2 + Just2(a : a, b : pad) + +type sublist + SCons(a : a, cs : sublist) + STuple(a : a, b : a) + +type partition + Sublist(c : sublist, bdl : partition) + Singleton(c : a, bdl : partition) + End + +fip fun quicksort(xs : list) : div list + quicksort-go(xs, End) + +fip fun quicksort-go(xs : list, b : partition) : div list + match xs + Cons(p, xx) -> + val (lo, hi) = split-list(p, xx, Done, b, Unit2(Pad,Pad)) + quicksort-go(lo, hi) + Nil -> quicksort-app(b) + +fip fun quicksort-app(bdl : partition) : div list + match bdl + Singleton(p, b) -> Cons(p,quicksort-app(b)) + Sublist(xs, bdl') -> match xs + SCons(p, xx) -> + val (lo, hi) = split-sublist(p, xx, Done, bdl', Unit2(Pad,Pad), Unit2(Pad,Pad)) + quicksort-go(lo, hi) + STuple(a, b) -> if a <= b then Cons(a, Cons(b, quicksort-app(bdl'))) + else Cons(b, Cons(a, quicksort-app(bdl'))) + End -> Nil + +type accum + MkLo(x : a, k : accum) + MkHi(x : a, k : accum) + Done + +fip fun split-list(p : elem, xs : list, k : accum, b : partition, u : unit2) : div (list, partition) + match xs + Cons(x, xx) -> if x < p then split-list(p, xx, MkLo(x, k), b, u) + else split-list(p, xx, MkHi(x, k), b, u) + Nil -> + val (lo, hi) = split-app1(k, Nil, Nothing2, b) + (lo, Singleton(p, hi)) + +fip fun split-sublist(p : elem, xs : sublist, k : accum, b : partition, u : unit2, u1 : unit2) :
(list, partition) + match xs + SCons(x, xx) -> if x < p then split-sublist(p, xx, MkLo(x, k), b, u, u1) + else split-sublist(p, xx, MkHi(x, k), b, u, u1) + STuple(x, y) -> split-list(p, Cons(x, Cons(y, Nil)), k, b, u) + +fip fun split-app1(k : accum, lo : list, hi : maybe2, b : partition) :
(list, partition) + match k + MkLo(x, k) -> split-app1(k, Cons(x, lo), hi, b) + MkHi(x, k) -> match hi + Nothing2 -> split-app1(k, lo, Just2(x, Pad), b) + Just2(y, _) -> split-app2(k, lo, STuple(y,x), b, Unit2(Pad,Pad)) + Done -> match hi + Just2(x, _) -> (lo, Singleton(x, b)) + Nothing2 -> (lo, b) + +fip fun split-app2(k : accum, lo : list, hi : sublist, b : partition, u : unit2) : (list, partition) + match k + MkLo(x, k) -> split-app2(k, Cons(x,lo), hi, b, u) + MkHi(x, k) -> split-app2(k, lo, SCons(x,hi), b, u) + Done -> (lo, Sublist(hi, b)) + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = quicksort(xs) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/qsort/qsort-std.kk b/test/fip/src/qsort/qsort-std.kk new file mode 100644 index 000000000..9c62aaf35 --- /dev/null +++ b/test/fip/src/qsort/qsort-std.kk @@ -0,0 +1,40 @@ +import std/num/int32 +import std/os/env + +alias elem = int32 + +fun quicksort(xs : list, res : list) : list + match(xs) + Cons(x, xx) -> + val (lo, hi) = partition(x, xx) + quicksort(lo, Cons(x, quicksort(hi, res))) + Nil -> res + +fun partition(^x : elem, ys : list) + match(ys) + Cons(y, yy) -> + if(y < x) then + val (lo, hi) = partition(x, yy) + (Cons(y, lo), hi) + else + val (lo, hi) = partition(x, yy) + (lo, Cons(y, hi)) + Nil -> (Nil, Nil) + +fun rand-list(n : int32, seed : int32) :
list + val a = 22695477.int32 + val c = 1.int32 + val next = a * seed + c + if n >= 0.int32 then Cons(next, rand-list(n - 1.int32, next)) + else Nil + +fun test(n : int32) + val xs = rand-list(n, 13.int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val ys = quicksort(xs, Nil) + acc + ys.last(0.int32) + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree-clrs-full.c b/test/fip/src/rbtree/rbtree-clrs-full.c new file mode 100644 index 000000000..29cfe80b1 --- /dev/null +++ b/test/fip/src/rbtree/rbtree-clrs-full.c @@ -0,0 +1,187 @@ +// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein +// When the tree is fully rebalanced, we continue to go up to the root along the parent pointers. + +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +enum Color { RED, BLACK }; +enum Bool { TRUE, FALSE }; + +typedef struct Node { + int32_t key; + enum Bool value; + enum Color color; + struct Node *left; + struct Node *right; + struct Node *parent; +} Node; + +typedef struct RedBlackTree { + Node *nil; + Node *root; +} RedBlackTree; + +void left_rotate(RedBlackTree *T, Node *x) { + Node *y = x->right; + x->right = y->left; + if (y->left != T->nil) { + y->left->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->left) { + x->parent->left = y; + } else { + x->parent->right = y; + } + y->left = x; + x->parent = y; +} + +void right_rotate(RedBlackTree *T, Node *x) { + Node *y = x->left; + x->left = y->right; + if (y->right != T->nil) { + y->right->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->right) { + x->parent->right = y; + } else { + x->parent->left = y; + } + y->right = x; + x->parent = y; +} + +void insert_fixup(RedBlackTree *T, Node *z) { + while (z->parent->color == RED) { + if (z->parent == z->parent->parent->left) { + Node *y = z->parent->parent->right; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->right) { + z = z->parent; + left_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + right_rotate(T, z->parent->parent); + } + } else { + Node *y = z->parent->parent->left; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->left) { + z = z->parent; + right_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + left_rotate(T, z->parent->parent); + } + } + } + while(z->parent != T->nil) { + z = z->parent; + } + T->root->color = BLACK; +} + +void insert(RedBlackTree *T, int32_t key, enum Bool value) { + Node *z = (Node *)malloc(sizeof(Node)); + z->key = key; + z->value = value; + Node *y = T->nil; + Node *x = T->root; + while (x != T->nil) { + y = x; + if (z->key < x->key) { + x = x->left; + } else { + x = x->right; + } + } + z->parent = y; + if (y == T->nil) { + T->root = z; + } else if (z->key < y->key) { + y->left = z; + } else { + y->right = z; + } + z->left = T->nil; + z->right = T->nil; + z->color = RED; + insert_fixup(T, z); +} + +RedBlackTree *empty_rbtree() { + Node *nil = (Node *)malloc(sizeof(Node)); + nil->color = BLACK; + RedBlackTree *t = (RedBlackTree *)malloc(sizeof(RedBlackTree)); + t->root = nil; + t->nil = nil; + return t; +} + +int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { + if (t == nil) { + return b; + } + int32_t left = fold(nil, t->left, b, f); + int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); + free(t); + return right; +} + +void make_tree_aux(int32_t n, RedBlackTree *t) { + if (n <= 0) return; + + int32_t n1 = n - 1; + insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); + make_tree_aux(n1, t); +} + +RedBlackTree *make_tree(int32_t n) { + RedBlackTree *t = empty_rbtree(); + make_tree_aux(n, t); + return t; +} + +int increment(int32_t k, enum Bool v, int32_t r) { + if(v == TRUE) { return r + 1; } else { return r; } +} + +void test(int n) { + int iter = 10000000 / MAX(n, 1); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + RedBlackTree *t = make_tree(n); + acc += fold(t->nil, t->root, 0, increment); + free(t->nil); + free(t); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree-clrs.c b/test/fip/src/rbtree/rbtree-clrs.c new file mode 100644 index 000000000..1a31ca7dc --- /dev/null +++ b/test/fip/src/rbtree/rbtree-clrs.c @@ -0,0 +1,183 @@ +// Red-black tree insertion as in 'Introduction to Algorithms', Cormen, Leiserson, Rivest, Stein + +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +enum Color { RED, BLACK }; +enum Bool { TRUE, FALSE }; + +typedef struct Node { + int32_t key; + enum Bool value; + enum Color color; + struct Node *left; + struct Node *right; + struct Node *parent; +} Node; + +typedef struct RedBlackTree { + Node *nil; + Node *root; +} RedBlackTree; + +void left_rotate(RedBlackTree *T, Node *x) { + Node *y = x->right; + x->right = y->left; + if (y->left != T->nil) { + y->left->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->left) { + x->parent->left = y; + } else { + x->parent->right = y; + } + y->left = x; + x->parent = y; +} + +void right_rotate(RedBlackTree *T, Node *x) { + Node *y = x->left; + x->left = y->right; + if (y->right != T->nil) { + y->right->parent = x; + } + y->parent = x->parent; + if (x->parent == T->nil) { + T->root = y; + } else if (x == x->parent->right) { + x->parent->right = y; + } else { + x->parent->left = y; + } + y->right = x; + x->parent = y; +} + +void insert_fixup(RedBlackTree *T, Node *z) { + while (z->parent->color == RED) { + if (z->parent == z->parent->parent->left) { + Node *y = z->parent->parent->right; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->right) { + z = z->parent; + left_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + right_rotate(T, z->parent->parent); + } + } else { + Node *y = z->parent->parent->left; + if (y->color == RED) { + z->parent->color = BLACK; + y->color = BLACK; + z->parent->parent->color = RED; + z = z->parent->parent; + } else { + if (z == z->parent->left) { + z = z->parent; + right_rotate(T, z); + } + z->parent->color = BLACK; + z->parent->parent->color = RED; + left_rotate(T, z->parent->parent); + } + } + } + T->root->color = BLACK; +} + +void insert(RedBlackTree *T, int32_t key, enum Bool value) { + Node *z = (Node *)malloc(sizeof(Node)); + z->key = key; + z->value = value; + Node *y = T->nil; + Node *x = T->root; + while (x != T->nil) { + y = x; + if (z->key < x->key) { + x = x->left; + } else { + x = x->right; + } + } + z->parent = y; + if (y == T->nil) { + T->root = z; + } else if (z->key < y->key) { + y->left = z; + } else { + y->right = z; + } + z->left = T->nil; + z->right = T->nil; + z->color = RED; + insert_fixup(T, z); +} + +RedBlackTree *empty_rbtree() { + Node *nil = (Node *)malloc(sizeof(Node)); + nil->color = BLACK; + RedBlackTree *t = (RedBlackTree *)malloc(sizeof(RedBlackTree)); + t->root = nil; + t->nil = nil; + return t; +} + +int fold(Node* nil, Node *t, int32_t b, int32_t(*f)(int32_t, enum Bool, int)) { + if (t == nil) { + return b; + } + int32_t left = fold(nil, t->left, b, f); + int32_t right = fold(nil, t->right, f(t->key, t->value, left), f); + free(t); + return right; +} + +void make_tree_aux(int32_t n, RedBlackTree *t) { + if (n <= 0) return; + + int32_t n1 = n - 1; + insert(t, n1, (n1 % 10 == 0) ? TRUE : FALSE); + make_tree_aux(n1, t); +} + +RedBlackTree *make_tree(int32_t n) { + RedBlackTree *t = empty_rbtree(); + make_tree_aux(n, t); + return t; +} + +int increment(int32_t k, enum Bool v, int32_t r) { + if(v == TRUE) { return r + 1; } else { return r; } +} + +void test(int n) { + int iter = 10000000 / MAX(n, 1); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + RedBlackTree *t = make_tree(n); + acc += fold(t->nil, t->root, 0, increment); + free(t->nil); + free(t); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree-fip-clrs.kk b/test/fip/src/rbtree/rbtree-fip-clrs.kk new file mode 100644 index 000000000..370801adc --- /dev/null +++ b/test/fip/src/rbtree/rbtree-fip-clrs.kk @@ -0,0 +1,91 @@ +import std/num/int32 +import std/os/env + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf + +fip fun is-red(^t : tree) : bool + match t + Node(Red) -> True + _ -> False + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fip(1) fun ins(t : tree, key : int32, v : bool, z : accum) : exn tree + match t + Node(c, l, kx, vx, r) + -> if key < kx then ins(l, key, v, NodeL(c, z, kx, vx, r)) + elif key > kx then ins(r, key, v, NodeR(c, l, kx, vx, z)) + else balance(z, Node(c, l, key, v, r)) + Leaf -> balance(z, Node(Red, Leaf, key, v, Leaf)) + +fip fun set-black(t : tree) : tree + match t + Node(_, l, k, v, r) -> Node(Black, l, k, v, r) + t -> t + +fip fun rebuild(z : accum, t : tree) // Turn the zipper into a tree without rotating + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fip fun balance( z : accum, t : tree ) : exn tree + match z + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> // black + if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black, l1, k1, v1, t) )) + else rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l1), k1, v1, t)) + NodeL(_,z2,k2,v2,r2) -> // black + if is-red(r2) then balance(z2, Node(Red, Node(Black,l1,k1,v1,t), k2, v2, r2.set-black)) + else match t + Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l1,k1,v1,l), k, v, Node(Red,r,k2,v2,r2))) + Done -> Node(Black, l1, k1, v1, t) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeL(_,z2,k2,v2,r2) -> // black + if is-red(r2) then balance(z2, Node(Red, Node(Black, t, k1, v1, r1), k2, v2, r2.set-black )) + else rebuild(z2, Node(Black, t, k1, v1, Node(Red,r1,k2,v2,r2))) + NodeR(_,l2,k2,v2,z2) -> // black + if is-red(l2) then balance(z2, Node(Red, l2.set-black, k2, v2, Node(Black,t,k1,v1,r1) )) + else match t + Node(_, l, k, v, r) -> rebuild(z2, Node(Black, Node(Red,l2,k2,v2,l), k, v, Node(Red,r,k1,v1,r1))) + Done -> Node(Black, t, k1, v1, r1) + z -> rebuild(z, t) + + +fip(1) fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree-fip-icfp.kk b/test/fip/src/rbtree/rbtree-fip-icfp.kk new file mode 100644 index 000000000..9ae787768 --- /dev/null +++ b/test/fip/src/rbtree/rbtree-fip-icfp.kk @@ -0,0 +1,77 @@ +import std/num/int32 +import std/os/env + +ref type pad + Pad + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + +type balance-node + Balance(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fip fun rebuild(z : accum, t : tree) : tree + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fip fun balance( z : accum, l : tree, k : int32, v : bool, r : tree, u : balance-node ) : tree + match z + NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) + NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r), u ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2), u ) + Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1), u ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2), u ) + Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) + Done -> Node(Black,l,k,v,r) + +fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree + match t + Node(c, l, kx, vx, r) + -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) + elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) + else rebuild(z, Node(c, l, kx, vx, r)) + Leaf -> balance(z, Leaf, k, v, Leaf, Balance(Red,Leaf,0.int32,True,Leaf)) + +fip(1) fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/rbtree/rbtree-fip.kk b/test/fip/src/rbtree/rbtree-fip.kk new file mode 100644 index 000000000..ad21e327f --- /dev/null +++ b/test/fip/src/rbtree/rbtree-fip.kk @@ -0,0 +1,79 @@ +import std/num/int32 +import std/os/env + +type any + Any + +type color + Red + Black + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + +type balance-node + Balance(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + +type accum + Done + NodeL(color : color, lchild : accum, key : int32, value : bool, rchild : tree) + NodeR(color : color, lchild : tree, key : int32, value : bool, rchild : accum) + +fip fun rebuild(z : accum, t : tree) : tree + match z + NodeR(c, l, k, v, z1) -> rebuild(z1, Node(c, l, k, v, t)) + NodeL(c, z1, k, v, r) -> rebuild(z1, Node(c, t, k, v, r)) + Done -> t + +fip fun balance( z : accum, t : balance-node ) : tree + match t + Balance(_,l,k,v,r) -> + match z + NodeR(Black, l1, k1, v1, z1) -> rebuild( z1, Node( Black, l1, k1, v1, Node(Red,l,k,v,r) ) ) + NodeL(Black, z1, k1, v1, r1) -> rebuild( z1, Node( Black, Node(Red,l,k,v,r), k1, v1, r1 ) ) + NodeR(Red, l1, k1, v1, z1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l1), k1, v1, Node(Black,l,k,v,r)) ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l1,k1,v1,l), k, v, Node(Black,r,k2,v2,r2)) ) + Done -> Node(Black, l1, k1, v1, Node(Red,l,k,v,r)) + NodeL(Red, z1, k1, v1, r1) -> match z1 + NodeR(_,l2,k2,v2,z2) -> balance( z2, Balance(Black, Node(Black,l2,k2,v2,l), k, v, Node(Black,r,k1,v1,r1)) ) + NodeL(_,z2,k2,v2,r2) -> balance( z2, Balance(Black, Node(Black,l,k,v,r), k1, v1, Node(Black,r1,k2,v2,r2)) ) + Done -> Node(Black, Node(Red,l,k,v,r), k1, v1, r1) + Done -> Node(Black,l,k,v,r) + +fip(1) fun ins(t : tree, k : int32, v : bool, z : accum) : tree + match t + Node(c, l, kx, vx, r) + -> if k < kx then ins(l, k, v, NodeL(c, z, kx, vx, r)) + elif k > kx then ins(r, k, v, NodeR(c, l, kx, vx, z)) + else rebuild(z, Node(c, l, kx, vx, r)) + Leaf -> balance(z, Balance(Black, Leaf, k, v, Leaf)) + +fip(1) fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v, Done) + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : pure tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : pure tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/rbtree/rbtree-std.kk b/test/fip/src/rbtree/rbtree-std.kk new file mode 100644 index 000000000..f16c30227 --- /dev/null +++ b/test/fip/src/rbtree/rbtree-std.kk @@ -0,0 +1,91 @@ +// Adapted from https://github.com/leanprover/lean4/blob/IFL19/tests/bench/rbmap.lean +import std/num/int32 +import std/os/env + +type color + Red + Black + + +type tree + Node(color : color, lchild : tree, key : int32, value : bool, rchild : tree) + Leaf() + + +fun is-red(^t : tree) : bool + match t + Node(Red) -> True + _ -> False + + +fun balance-left(l :tree, k : int32, v : bool, r : tree) : tree + match l + Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) + -> Node(Red, Node(Black, lx, kx, vx, rx), ky, vy, Node(Black, ry, k, v, r)) + Node(_, ly, ky, vy, Node(Red, lx, kx, vx, rx)) + -> Node(Red, Node(Black, ly, ky, vy, lx), kx, vx, Node(Black, rx, k, v, r)) + Node(_, lx, kx, vx, rx) + -> Node(Black, Node(Red, lx, kx, vx, rx), k, v, r) + Leaf -> Leaf + + +fun balance-right(l : tree, k : int32, v : bool, r : tree) : tree + match r + Node(_, Node(Red, lx, kx, vx, rx), ky, vy, ry) + -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, rx, ky, vy, ry)) + Node(_, lx, kx, vx, Node(Red, ly, ky, vy, ry)) + -> Node(Red, Node(Black, l, k, v, lx), kx, vx, Node(Black, ly, ky, vy, ry)) + Node(_, lx, kx, vx, rx) + -> Node(Black, l, k, v, Node(Red, lx, kx, vx, rx)) + Leaf -> Leaf + + +fun ins(t : tree, k : int32, v : bool) : tree + match t + Node(Red, l, kx, vx, r) + -> if k < kx then Node(Red, ins(l, k, v), kx, vx, r) + elif k > kx then Node(Red, l, kx, vx, ins(r, k, v)) + else Node(Red, l, k, v, r) + Node(Black, l, kx, vx, r) + -> if k < kx then (if is-red(l) then balance-left(ins(l,k,v), kx, vx, r) + else Node(Black, ins(l, k, v), kx, vx, r)) + elif k > kx then (if is-red(r) then balance-right(l, kx, vx, ins(r,k,v)) + else Node(Black, l, kx, vx, ins(r, k, v))) + else Node(Black, l, k, v, r) + Leaf -> Node(Red, Leaf, k, v, Leaf) + + +fun set-black(t : tree) : tree + match t + Node(_, l, k, v, r) -> Node(Black, l, k, v, r) + _ -> t + + +fun insert(t : tree, k : int32, v : bool) : tree + ins(t, k, v).set-black + + +fun fold(t : tree, b : a, f: (int32, bool, a) -> a) : a + match t + Node(_, l, k, v, r) -> r.fold( f(k, v, l.fold(b, f)), f) + Leaf -> b + + +fun make-tree-aux(n : int32, t : tree) : div tree + if n <= zero then t else + val n1 = n.dec + make-tree-aux(n1, insert(t, n1, n1 % 10.int32 == zero)) + +pub fun make-tree(n : int32) : div tree + make-tree-aux(n, Leaf) + + +fun test(n : int32) + val x = fold-int32(0.int32, (10_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + val t = make-tree(n) + acc + t.fold(zero) fn(k,v,r:int32){ if v then r.inc else r } + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) \ No newline at end of file diff --git a/test/fip/src/rbtree/rbtree-stl.cpp b/test/fip/src/rbtree/rbtree-stl.cpp new file mode 100644 index 000000000..fbc9b5927 --- /dev/null +++ b/test/fip/src/rbtree/rbtree-stl.cpp @@ -0,0 +1,64 @@ +// Using standard STL to test the red-black tree in C++ +// In glibc++ this uses +// With the LLVM libc++ this uses +// In glibc this uses eventually: +// (Highly optimized in-place red-black tree using the low pointer bit to encode color information.) + +#include +#include +#include +using std::for_each; + +typedef int32_t nat; + +struct nat_lt_fn { + bool operator()(nat const & n1, nat const & n2) const { return n1 < n2; } +}; + +typedef std::map map; + +map mk_map(unsigned n) { + map m; + while (n > 0) { + --n; + m.insert(std::make_pair(nat(n), n%10 == 0)); + } + return m; +} + +nat fold(map const & m) { + nat r(0); + for_each(m.begin(), m.end(), [&](std::pair const & p) { if (p.second) r = r + nat(1); }); + return r; +} + +/* +int main(int argc, char ** argv) { + unsigned n = 4200000; + if (argc == 2) { + n = atoi(argv[1]); + } + map m = mk_map(n); + std::cout << fold(m) << "\n"; + return 0; +} +*/ + +void test(int n) { + int iter = 10000000 / (n <= 0 ? 1 : n); + int32_t acc = 0; + for(int i = 0; i < iter; i++) { + map m = mk_map(n); + acc += fold(m); + } + printf("total: %d\n", acc); +} + +int main(int argc, char *argv[]) { + int n = 100; + if (argc > 1) { + n = atoi(argv[1]); + } + test(n); + return 0; +} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap-fip.c b/test/fip/src/tmap/tmap-fip.c new file mode 100644 index 000000000..b30e2754d --- /dev/null +++ b/test/fip/src/tmap/tmap-fip.c @@ -0,0 +1,101 @@ +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +struct node { + int32_t header; + int32_t data; + struct node* left; + struct node* right; +}; + +struct node* create_node(int32_t data) { + struct node* new_node = (struct node*)malloc(sizeof(struct node)); + new_node->header = 0; + new_node->data = data; + new_node->left = NULL; + new_node->right = NULL; + return new_node; +} + +struct node* insert_range(int32_t start, int32_t end) { + if (start > end) return NULL; + + int32_t mid = start + (end - start) / 2; + struct node* root = create_node(mid); + + root->left = insert_range(start, mid - 1); + root->right = insert_range(mid + 1, end); + + return root; +} + +int sum_tree(struct node* root) { + if (root == NULL) return 0; + + int n = root->data + sum_tree(root->left) + sum_tree(root->right); + free(root); + return n; +} + +struct node* tmap(struct node* root, int32_t (*f)(int32_t)) { + struct node* acc = NULL; + + acc: + while(root != NULL) { + struct node* acc_ = create_node(root->data); + acc_->left = acc; + acc_->right = root->right; + root = root->left; + acc = acc_; + } + + app: + if(acc == NULL) return root; + if(acc->header == 0) { + struct node* right = acc->right; + acc->header = 1; + acc->data = f(acc->data); + acc->right = acc->left; + acc->left = root; + root = right; + goto acc; + } else { // acc->header == 1 + struct node* acc_ = acc->right; + acc->right = root; + root = acc; + acc = acc_; + goto app; + } +} + +int increment(int x){ + return x+1; +} + +void test(int n) { + struct node* xs = insert_range(1, n); + int iter = 100000000 / MAX(n, 1); + int32_t x = 0; + + for(int i = 0; i < iter; i++) { + x += sum_tree(tmap(xs, increment)); + } + sum_tree(xs); // free xs + + printf("total: %d\n", x); +} + +int main(int argc, char* argv[]) { + int n; + if (argc < 2) { + printf("Please provide a natural number as an argument.\n"); + return 0; + } else { + n = atoi(argv[1]); + } + + test(n); + + return 0; +} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap-fip.kk b/test/fip/src/tmap/tmap-fip.kk new file mode 100644 index 000000000..861765715 --- /dev/null +++ b/test/fip/src/tmap/tmap-fip.kk @@ -0,0 +1,47 @@ +import std/num/int32 +import std/os/env + +type tree + Leaf + Bin(l : tree, a : a, r : tree) + +fun tree32(lo : int32, hi : int32) + if lo > hi then Leaf + else + val mi = lo + (hi - lo) / 2.int32 + Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) + +fun tsum32_go(t, acc : int32) + match t + Leaf -> acc + Bin(l, a, r) -> tsum32_go(r, tsum32_go(l, acc + a)) + +fun tsum32(t0 : tree) + tsum32_go(t0, 0.int32) + +type accum + Hole + BinR(k : accum, x : a, r : tree) + BinL(l : tree, x : b, k : accum) + +fun tmap-acc( t : tree, ^f : a -> e b, k : accum) : e tree + match t + Leaf -> tmap-app( k, f, Leaf ) + Bin(l, x, r) -> tmap-acc( l, f, BinR(k, x, r) ) + +fun tmap-app( k0 : accum, ^f : a -> e b, t : tree ) : e tree + match k0 + BinR(k, x, r) -> tmap-acc( r, f, BinL( t, f(x), k ) ) + BinL(l, x, k) -> tmap-app( k, f, Bin(l, x, t) ) + Hole -> t + +fun test(n : int32) + val xs = tree32(1.int32,n) + val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + acc + xs.tmap-acc(fn(x) x.inc, Hole).tsum32 + println("total: " ++ x.show) + + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/fip/src/tmap/tmap-std.c b/test/fip/src/tmap/tmap-std.c new file mode 100644 index 000000000..520951f78 --- /dev/null +++ b/test/fip/src/tmap/tmap-std.c @@ -0,0 +1,82 @@ +#include +#include +#define MAX(a,b) (((a)>(b))?(a):(b)) + +struct node { + int32_t data; + struct node* left; + struct node* right; +}; + +struct node* create_node(int32_t data) { + struct node* new_node = (struct node*)malloc(sizeof(struct node)); + new_node->data = data; + new_node->left = NULL; + new_node->right = NULL; + return new_node; +} + +struct node* insert_range(int32_t start, int32_t end) { + if (start > end) return NULL; + + int32_t mid = start + (end - start) / 2; + struct node* root = create_node(mid); + + root->left = insert_range(start, mid - 1); + root->right = insert_range(mid + 1, end); + + return root; +} + +int sum_tree(struct node* root) { + if (root == NULL) return 0; + + int n = root->data + sum_tree(root->left) + sum_tree(root->right); + free(root); + return n; +} + +void tmap(struct node* root, int32_t (*f)(int32_t), struct node** dest) { + while(root != NULL) { + struct node* root_ = create_node(root->data); + tmap(root->left, f, &root_->left); + root_->data = f(root_->data); + *dest = root_; + dest = &root_->right; + root = root->right; + } + *dest = NULL; +} + +int increment(int x){ + return x+1; +} + +void test(int n) { + struct node* xs = insert_range(1, n); + int iter = 100000000 / MAX(n, 1); + int32_t x = 0; + + for(int i = 0; i < iter; i++) { + struct node* ys; + tmap(xs, increment, &ys); + x += sum_tree(ys); + } + sum_tree(xs); // free xs + + printf("total: %d\n", x); +} + +int main(int argc, char* argv[]) { + int n; + if (argc < 2) { + printf("Please provide a natural number as an argument.\n"); + return 0; + } else { + n = atoi(argv[1]); + } + + test(n); + + return 0; +} \ No newline at end of file diff --git a/test/fip/src/tmap/tmap-std.kk b/test/fip/src/tmap/tmap-std.kk new file mode 100644 index 000000000..e41f79750 --- /dev/null +++ b/test/fip/src/tmap/tmap-std.kk @@ -0,0 +1,34 @@ +import std/num/int32 +import std/os/env + +type tree + Leaf + Bin(l : tree, a : a, r : tree) + +fun tree32(lo : int32, hi : int32) + if lo > hi then Leaf + else + val mi = lo + (hi - lo) / 2.int32 + Bin(tree32(lo, mi - 1.int32), mi, tree32(mi + 1.int32, hi)) + +fun tsum32(t0 : tree) + fun go(t, acc : int32) + match t + Leaf -> acc + Bin(l, a, r) -> go(r, go(l, acc + a)) + go(t0, 0.int32) + +fun tmap-std( xs : tree, f : a -> e b ) : e tree + match xs + Bin(l,x,r) -> Bin(l.tmap-std(f),f(x),r.tmap-std(f)) + Leaf -> Leaf + +fun test(n : int32) + val xs = tree32(1.int32,n) + val x = fold-int32(0.int32, (100_000_000.int32)/(max(n,1.int32)), 0.int32) fn(i,acc) + acc + xs.tmap-std(fn(x) x.inc).tsum32 + println("total: " ++ x.show) + +fun main() + val n = get-args().head("").parse-int.default(100).int32 + test(n) diff --git a/test/kind/type3.kk.out b/test/kind/type3.kk.out index b3ffd8e4d..442b5c054 100644 --- a/test/kind/type3.kk.out +++ b/test/kind/type3.kk.out @@ -1 +1,3 @@ +test/kind/type3.kk(1, 1): warning: Type maybe may be better declared as a value type for efficiency (e.g. 'value type/struct'), + or declared as a reference type to suppress this warning (e.g. 'ref type/struct') kind/type3/maybe: V -> V \ No newline at end of file diff --git a/test/lib/bigint3.kk b/test/lib/bigint3.kk new file mode 100644 index 000000000..c85950bac --- /dev/null +++ b/test/lib/bigint3.kk @@ -0,0 +1,8 @@ +// test for TAOCP Vol 2 bigint division bug (1st & 2nd edition), +// see: + +noinline fun muldiv( x : int, y : int, z : int ) : int + (x*y)/z + +pub fun main() + muldiv(18446744069414584318, 4294967296, 18446744069414584319).println // 4294967295 diff --git a/test/lib/bigint3.kk.out b/test/lib/bigint3.kk.out new file mode 100644 index 000000000..b7bf491bc --- /dev/null +++ b/test/lib/bigint3.kk.out @@ -0,0 +1 @@ +4294967295 \ No newline at end of file diff --git a/test/medium/garcia-wachs.kk b/test/medium/garcia-wachs.kk index 40870e92f..270db94a5 100644 --- a/test/medium/garcia-wachs.kk +++ b/test/medium/garcia-wachs.kk @@ -24,7 +24,7 @@ fun show( t : tree ) : string //---------------------------------------------------- // Non empty lists //---------------------------------------------------- -pub type list1 { +pub ref type list1 { Cons1( head : a, tail : list ) } diff --git a/test/parc/parc2.kk.out b/test/parc/parc2.kk.out index 5cf72b7b9..827d08bf9 100644 --- a/test/parc/parc2.kk.out +++ b/test/parc/parc2.kk.out @@ -3,5 +3,10 @@ import std/core/types = std/core/types = ""; import std/core = std/core = ""; pub fun test : forall (x : list) -> list = fn(x: list<0>){ - std/core/append((std/core/types/.dup(x)), x); + match (x) { + (std/core/Nil() : (list) ) + -> x; + _ + -> std/core/.unroll17330-append((std/core/types/.dup(x)), x); + }; }; \ No newline at end of file diff --git a/test/parc/parc22.kk.out b/test/parc/parc22.kk.out index a234ddd93..37570db21 100644 --- a/test/parc/parc22.kk.out +++ b/test/parc/parc22.kk.out @@ -2,7 +2,7 @@ module parc/parc22 import std/core/types = std/core/types = ""; import std/core = std/core = ""; pub rec type parc/parc22/hello { - pub con parc/parc22/World(i: int) : (i : int) -> parc/parc22/hello; + pub con parc/parc22/World(i: int){0,1,8} : (i : int) -> parc/parc22/hello; }; // Automatically generated. Retrieves the `i` constructor field of the `:hello` type. pub fun i : (^ hello : parc/parc22/hello) -> int @@ -16,11 +16,17 @@ pub fun .copy : (.this : parc/parc22/hello, i : optional) -> parc/parc22/he = fn(.this: parc/parc22/hello, i0: optional){ parc/parc22/World((match (i0) { (std/core/types/Optional(((.skip std/core/types/.Box((.i: int)) : .Box ) as .box: .Box)) : optional ) - -> val _ : () + -> val _ : int + = std/core/types/.dup(.i); + val _ : () + = std/core/types/.drop(i0); + val _ : () = std/core/types/.drop(.this, (std/core/int32(1))); .i; (.skip std/core/types/None() : (optional) ) - -> (match (.this) { + -> val _ : () + = std/core/types/.drop(i0); + (match (.this) { (.skip parc/parc22/World((.x: int)) : parc/parc22/hello ) -> val _ : () = (match ((std/core/types/.is-unique(.this))) { diff --git a/test/readme.md b/test/readme.md index f38801f75..a5bafb437 100644 --- a/test/readme.md +++ b/test/readme.md @@ -36,6 +36,7 @@ Options: --cabal # Use cabal to run koka. --system-ghc # If using stack, use --system-ghc option. --target-js # Test javascript backend +--target-c64c # Test compressed heap -O2 # Use optimization -O-1 # Full debug mode with internal runtime assertions enabled --seq # Test sequentially (instead of in parallel) diff --git a/test/static/wrong/duplicate3.kk b/test/static/wrong/duplicate3.kk index f10060448..fae218c44 100644 --- a/test/static/wrong/duplicate3.kk +++ b/test/static/wrong/duplicate3.kk @@ -1,2 +1,2 @@ // duplicate constructor -type dup { Dup1(:int); Dup1(:int) } +ref type dup { Dup1(:int); Dup1(:int) } diff --git a/test/static/wrong/duplicate3.kk.out b/test/static/wrong/duplicate3.kk.out index 0eb3a5d12..60327f1c3 100644 --- a/test/static/wrong/duplicate3.kk.out +++ b/test/static/wrong/duplicate3.kk.out @@ -1 +1 @@ -test/static/wrong/duplicate3.kk(2,25): error: Constructor static/wrong/duplicate3/Dup1 is already defined at (2,13) \ No newline at end of file +test/static/wrong/duplicate3.kk(2,29): error: Constructor static/wrong/duplicate3/Dup1 is already defined at (2,17) \ No newline at end of file diff --git a/test/type/args1.kk b/test/type/args1.kk index c1858e0fd..17f811bc0 100644 --- a/test/type/args1.kk +++ b/test/type/args1.kk @@ -1,4 +1,4 @@ -struct test( x : int, y : int = 0 ) +value struct test( x : int, y : int = 0 ) fun foo() { Test(1) diff --git a/test/type/hm3.kk b/test/type/hm3.kk new file mode 100644 index 000000000..9c0a4199f --- /dev/null +++ b/test/type/hm3.kk @@ -0,0 +1,6 @@ +fun f(y) + val h = fn(x) f(x) + h(y) + +fun g(x) + g(x) \ No newline at end of file diff --git a/test/type/hm3.kk.out b/test/type/hm3.kk.out new file mode 100644 index 000000000..3ef31cd20 --- /dev/null +++ b/test/type/hm3.kk.out @@ -0,0 +1,2 @@ +type/hm3/f: forall (a) -> div b +type/hm3/g: forall (a) -> div b \ No newline at end of file diff --git a/test/type/warn1.kk b/test/type/warn1.kk index 6153ac719..0ed952fd4 100644 --- a/test/type/warn1.kk +++ b/test/type/warn1.kk @@ -2,7 +2,7 @@ fun f(xs) { fun len(xs) { match(xs) { - Cons(_,xs) -> len(xs) + Cons(_,xx) -> len(xx) _ -> 0 } } diff --git a/test/type/warn1.kk.out b/test/type/warn1.kk.out index 43176228d..2b3e20056 100644 --- a/test/type/warn1.kk.out +++ b/test/type/warn1.kk.out @@ -1,3 +1,2 @@ test/type/warn1.kk(3,11): warning: xs shadows an earlier local definition or parameter -test/type/warn1.kk(5,14): warning: xs shadows an earlier local definition or parameter type/warn1/f: forall (xs : list) -> int \ No newline at end of file diff --git a/util/Dockerfile b/util/Dockerfile index 3eb0eb987..b6798f103 100644 --- a/util/Dockerfile +++ b/util/Dockerfile @@ -1,4 +1,4 @@ -# Created by @Lassik +# Create a docker image with a working Koka compiler (including sources). # # Build: # > docker build -t . @@ -8,29 +8,41 @@ # or # > docker run -v -it # +# To start with a shell prompt: +# > docker run -it bash +# # To publish, use a tag like `kokalang/koka:v2.x.x` # > docker push FROM haskell:8.10.7 AS build -RUN mkdir -p ~/.local/bin \ - && cp /usr/local/bin/stack ~/.local/bin/stack \ - && find /usr/local -type f -delete -RUN apt-get update \ - && apt-get install -y --no-install-recommends cmake \ - && rm -rf /var/lib/apt/lists/* +ENV KOKAVER=dev + +RUN mkdir -p ~/.local/bin +RUN cp /usr/local/bin/stack ~/.local/bin/stack +RUN find /usr/local -type f -delete +RUN apt-get update +RUN apt-get install -y --no-install-recommends ca-certificates +RUN apt-get install -y --no-install-recommends libc-dev build-essential tar cmake +RUN apt-get install -y --no-install-recommends gcc curl + +# Build Koka WORKDIR /build -RUN git clone --recursive https://github.com/koka-lang/koka -b v2.4.0 +RUN git clone --recursive https://github.com/koka-lang/koka -b ${KOKAVER} WORKDIR /build/koka RUN stack build -RUN stack exec koka -- util/bundle -- --postfix=docker -FROM debian:buster -RUN apt-get update \ - && apt-get install -y --no-install-recommends \ - gcc libc-dev make \ - nodejs ca-certificates \ - && rm -rf /var/lib/apt/lists/* -COPY --from=build /build/koka/bundle/koka-docker.tar.gz /usr/local -WORKDIR /usr/local -RUN tar -xzvf koka-docker.tar.gz +# For installing C libraries (pcre2) we use Conan +RUN apt-get install -y --no-install-recommends python3-pip +RUN pip3 install setuptools wheel +RUN pip3 install conan + +# Build Koka install bundle +RUN stack exec koka -- -e util/bundle -- --postfix=docker --prefix=bundle/docker + +# Install +WORKDIR /usr/local +RUN tar -xzvf /build/koka/bundle/koka-docker.tar.gz + +# Entry +WORKDIR /build/koka CMD ["koka"] diff --git a/util/Dockerfile-minimal b/util/Dockerfile-minimal new file mode 100644 index 000000000..066ede248 --- /dev/null +++ b/util/Dockerfile-minimal @@ -0,0 +1,56 @@ +# Create a minimal docker image with a working Koka compiler (binaries only). +# Initial version written by @Lassik +# +# Build: +# > docker build -t -f Dockerfile-minimal . +# +# To Run: +# > docker run -it +# or +# > docker run -v -it +# +# To start with a shell prompt: +# > docker run -it bash +# +# To publish, use a tag like `kokalang/koka:v2.x.x` +# > docker push + + +FROM haskell:8.10.7 AS build +ENV KOKAVER=dev + +RUN mkdir -p ~/.local/bin +RUN cp /usr/local/bin/stack ~/.local/bin/stack +RUN find /usr/local -type f -delete +RUN apt-get update +RUN apt-get install -y --no-install-recommends ca-certificates +RUN apt-get install -y --no-install-recommends libc-dev build-essential tar cmake +RUN apt-get install -y --no-install-recommends gcc curl + +# Build Koka +WORKDIR /build +RUN git clone --recursive https://github.com/koka-lang/koka -b ${KOKAVER} +WORKDIR /build/koka +RUN stack build + +# For installing C libraries (pcre2) we use Conan +RUN apt-get install -y --no-install-recommends python3-pip +RUN pip3 install setuptools wheel +RUN pip3 install conan + +# Create install bundle +RUN stack exec koka -- -e util/bundle -- --postfix=docker --prefix=bundle/docker + +# Create fresh image with just the binaries +FROM debian:buster +RUN apt-get update +RUN apt-get install -y --no-install-recommends gcc libc-dev make +RUN apt-get install -y --no-install-recommends ca-certificates +# apt-get install -y --no-install-recommends nodejs +# RUN rm -rf /var/lib/apt/lists/* +COPY --from=build /build/koka/bundle/koka-docker.tar.gz /usr/local +WORKDIR /usr/local +RUN tar -xzvf koka-docker.tar.gz +WORKDIR /root +RUN mkdir .koka +CMD ["koka"] diff --git a/util/README.md b/util/README.md new file mode 100644 index 000000000..91198f9e2 --- /dev/null +++ b/util/README.md @@ -0,0 +1,57 @@ +# Utilities + +- `bundle.kk`: creates a fresh release bundle. +- `install.`[`bat`,`sh`]: installer scripts that install bundles. +- `minbuild.sh`: a script to run a build with minimal dependencies (if you don't have `stack` or `cabal`). +- `link-`[`min`,`test`,`std`]: wrapper module to build and link most standard libraries for an install bundle. +- `grammar.kk`: build and test the yacc & flex grammar. +- `packaging`: build packages for various Linux distributions. + + +# Releasing + +Ensure latest stack: + +``` +$ stack upgrade +$ stack update +``` + +Bump the Koka version in files: + +- `package.yaml` (2 places!) +- `util/install.sh` +- `util/install.bat` +- `util/Dockerfile` +- `util/minbuild.sh` + +Compile Koka: + +``` +$ stack build +$ stack exec koka # check if interpreter works + +> :l samples/all +> all/main() +... + +> :q + +$ stack test +``` + +and create a bundle: + +``` +$ stack exec koka -- -e util/bundle.kk +``` + +(On Windows, to this in an Visual Studio x64 command line tools console). + +Test installation: + +``` +$ util/install.sh ./bundle/v/koka-v--.tar.gz +``` + +Copy the bundles from `bundle/v/koka-v--.tar.gz` and upload them. diff --git a/util/bundle.kk b/util/bundle.kk index c661907a8..bed005366 100644 --- a/util/bundle.kk +++ b/util/bundle.kk @@ -14,7 +14,7 @@ import std/os/flags import std/time/time import std/time/utc -val header = "usage:\n stack exec koka -- util/bundle [-- [options]]\n\noptions:" +val header = "usage:\n stack exec koka -- -e util/bundle [-- [options]]\n\noptions:" struct iflags prefixdir : string = "" diff --git a/util/install.bat b/util/install.bat index a6ce2d8e4..d337f5331 100644 --- a/util/install.bat +++ b/util/install.bat @@ -4,7 +4,7 @@ rem Installation script for Koka; use -h to see command line options. rem ------------------------------------------------------------------ setlocal -set KOKA_VERSION=v2.4.0 +set KOKA_VERSION=v2.4.2 set KOKA_PREFIX=%LOCALAPPDATA%\koka set KOKA_UNINSTALL=N set KOKA_HELP=N @@ -17,11 +17,12 @@ set KOKA_PREV_VERSION= set KOKA_PREV_PREFIX= set KOKA_ARCH=x64 -set CLANG_VERSION=13.0.0 +set CLANG_VERSION=16.0.6 set CLANG_INSTALL_BASE=LLVM-%CLANG_VERSION%-win64.exe set CLANG_INSTALL=%TEMP%\%CLANG_INSTALL_BASE% set CLANG_INSTALL_URL=https://github.com/llvm/llvm-project/releases/download/llvmorg-%CLANG_VERSION%/%CLANG_INSTALL_BASE% -set CLANG_INSTALL_SHA256=f81f08a8bd9d787ec0505a7475cdff9653516cbbc5804e973f8749a2139fa1cb +set CLANG_INSTALL_SHA256=9a8cd30cc92fdf403d96217347861545a5bbff7a1a1a8527b5785ff0e9101111 + rem check if %LOCALAPPDATA% was not empty if "%KOKA_PREFIX%" == "\koka" (set KOKA_PREFIX=c:\usr\local\koka) diff --git a/util/install.sh b/util/install.sh index 259c2645f..0e3e5ddfc 100755 --- a/util/install.sh +++ b/util/install.sh @@ -4,7 +4,7 @@ # Installation script for Koka; use -h to see command line options. #----------------------------------------------------------------------------- -VERSION="v2.4.0" +VERSION="v2.4.2" MODE="install" # or uninstall PREFIX="/usr/local" QUIET="" @@ -318,7 +318,7 @@ install_dependencies() { elif has_cmd yum ; then yum_install build-essential $deps elif has_cmd apk ; then - deps="gcc make tar curl cmake" + deps="gcc make tar curl cmake ninja" apk_install $deps elif has_cmd pacman; then deps="gcc make tar curl cmake ninja pkg-config" # ninja-build -> ninja diff --git a/util/minbuild.sh b/util/minbuild.sh index b36823e8a..b2604e59e 100755 --- a/util/minbuild.sh +++ b/util/minbuild.sh @@ -5,7 +5,7 @@ # For use on platforms where stack is not working and to document # the minimal needed commands to build the full compiler. -KOKA_VERSION=2.4.0 +KOKA_VERSION=2.4.2 KOKA_VARIANT=release echo ""