From 1b7ee187ba8adf21eed2f7e335fe74b80d34ff84 Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Mon, 18 May 2026 16:26:29 +0100 Subject: [PATCH 1/8] cut proposal --- docs/CUT.md | 140 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 140 insertions(+) create mode 100644 docs/CUT.md diff --git a/docs/CUT.md b/docs/CUT.md new file mode 100644 index 00000000..7c6494d7 --- /dev/null +++ b/docs/CUT.md @@ -0,0 +1,140 @@ +# Re-instating the `cut` directive + +Note on continuations: old docs say "fail" instead of "back", "fail" and "back" continuations are the same thing but I want to move towards using "back" for these continuations in future. + +## What is it? + +`cut` is a unary special form `cut expr`, somewhat equivalent to the Prolog +"green cut" `!` operation. It commits to the current decision branch during +backtracking. If backtracked through, no additional choices at that +particular decision point will be attempted. The expression has the same type +and value as `expr`, but its control effect happens before `expr` is +evaluated. + +## How it works + +Conceptually `cut` prunes the current "back" continuation, so that +backtracking proceeds immediately to the previous "back" continuation, +skipping the one that was cut. Because it is a special form, this pruning +happens before evaluation of the argument expression. + +## What already exists + +There was an end-to-end implementation of `cut` on the CEKF path but this was somehow dropped. There is still unused code in the ANF transform `anf_normalize.c`, `anf.yaml` etc. and the CEKF machine `step.c`, `cekfs.yaml` etc. but it is missing from the AST, lambda conversion, type-checking and `minlam.yaml`. + +## How is it implemented? + +On the default CEKF path, `cut expr` lowers to the existing ANF form `(cut +expr)`. The `CUT` instruction merely replaces the back continuation register +with the parent: `F->F`, then execution continues with `expr`. The emitted +bytecode performs `CUT` before the code for `expr`, so the new back +continuation is already installed while `expr` is being evaluated. + +If `cut` is executed when the current back continuation is `NULL`, that is a +run-time error. + +Hopefully the CEKF path still works. + +On the CPS path, each `back` continuation should take a boolean `skip` +argument. If `skip = true`, it should immediately call its parent `back` +continuation; otherwise it should perform its normal work. `cut` should then +install a new failure continuation that will call its parent with +`skip = true`, and it should do that before evaluating the argument +expression. All ordinary `back` calls should pass `skip = false`. + +If the final back continuation is invoked with `skip = true`, that is a +run-time error. + +## Resolved design decisions + +- Keep the surviving expression-wrapper shape `(cut )` through the + front-end IRs rather than treating `cut` as a bare directive. +- Treat `cut` as a special form rather than an ordinary function application: + it installs its back-continuation effect before evaluating its argument. +- Give `cut expr` the type of `expr`. +- Treat `cut` with no current back continuation as a CEKF run-time error. +- Treat invocation of the final CPS back continuation with `skip = true` as a + run-time error. +- Use the pass order in `main()` as the source of truth for the pipeline + split, not the README architecture sketch. +- Treat the work as a shared path from parsing through uncurrying, followed + by separate default-CEKF and target-b/target-c tails. +- Expand the front-end work list to include the full parser and AST surface, + not just `ast.yaml`. +- The target-b/target-c tail in `main()` is not just `minlam_amb`; after the + split it runs `runCpsTrampolineTc`, a repeated `betaEtaFixedPoint`, + `ambMinExp`, a repeated `shakeMinExp`, the inline/beta/eta/shake/fold fixed + point, `checkMinExp`, closure conversion, `indexMinExp`, and finally target + emission. +- Some of those post-split minExp passes are repeats of shared-path passes, + while a few are unique to the target-b/target-c branch and may need small + additions or explicit validation. +- The CPS transform itself is the tricky branch-specific part. +- For the CPS path, the change should stay in `minlam_amb` unless later + validation shows another pass is making a hidden assumption. The current + target-b/target-c closure conversion and emitters count lambda arguments + generically and do not appear to hard-code failure-continuation arity. + +## Work to be done + +### Shared work through uncurrying + +This is the common path in `main()`: parse, `prepareAst`, `lowerAst`, +`lamConvertProg`, lambda simplification, type checking, constructor inlining, +`desugarLamExp`, `shakeMinExp`, `alphaConvertMinExp`, `curryMinExp`, +`betaEtaFixedPoint`, `foldMinExp`, and `uncurry`. + +1. Add `cut` to the scanner and Pratt parser as a prefix form `cut expr`. +2. Add it to `ast.yaml` and to the analogous syntax-template AST surface. +3. Update the surrounding AST pipeline pieces that currently mirror `back`: + parser validity checks, AST preparation, AST lowering, namespace handling, + and pretty-printing. +4. Add it to `lambda.yaml`, `lambda_conversion.c`, lambda simplification, and + any lambda visitors or printers that need to preserve it. +5. Pass it through type checking with `typeof(cut expr) == typeof(expr)`. +6. Add it to `minlam.yaml`, `lambda_desugar.c`, and the shared minlam support + code that needs to preserve or inspect the new form. +7. Update the shared pre-split minlam passes so `cut` survives through to the + post-uncurry split point in `main()`: shake, alpha conversion, currying, + beta/eta simplification, folding, pretty-printing, checking, and uncurrying. + +### Default CEKF path + +1. Carry `cut` through ANF as `CexpCut`. +2. Reconnect `anf_normalize.c` to lower `MinCut` to the already surviving + ANF `cut` form. +3. Confirm the CEKF runtime treats `cut` with `F == NULL` as a run-time error. + +### Target-b and target-c CPS path + +This tail in `main()` is: `runCpsTrampolineTc`, a repeated +`betaEtaFixedPoint`, `ambMinExp`, a repeated `shakeMinExp`, the post-split +inline fixed point (`inlineMinExp` plus repeated `betaEtaFixedPoint` and +`shakeMinExp`, plus `foldVecMinExp`, `foldIffMinExp`, and `foldCmpMinExp`), +`checkMinExp`, closure conversion, `indexMinExp`, and then target-b/target-c +emission. + +1. Thread `cut` through `runCpsTrampolineTc`; this is likely the trickiest + branch-specific change. +2. Confirm that the repeated post-split `betaEtaFixedPoint` and + `shakeMinExp` passes still behave correctly on the CPS-transformed IR once + the shared-path support is in place. +3. Rewrite `cut` away during `minlam_amb.c`. +4. Change the CPS back-continuation protocol so back continuations accept a + `skip` boolean. +5. Make ordinary `back` calls pass `skip = false`. +6. Make `cut` install a failure continuation that invokes its parent with + `skip = true`. +7. Audit the branch-only post-split transforms so they either never see + `cut` after `minlam_amb.c` or accept small plumbing additions as needed: + `inlineMinExp`, `foldVecMinExp`, `foldIffMinExp`, `foldCmpMinExp`, + `checkMinExp`, closure conversion, and `indexMinExp`. +8. Make the final back continuation report a run-time error when called with + `skip = true`. + +### Tests + +1. Basic commit behaviour. +2. Nested `amb` and `cut`. +3. `cut` with no enclosing choice point. +4. Interaction with `here` and escaped continuations. From d82c6c3e48b9dca1a2b645e3f52b15ddbdf479f8 Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Mon, 18 May 2026 16:56:06 +0100 Subject: [PATCH 2/8] cut parsing in place --- docs/CUT.md | 93 +++++++++++++++++++++++++++++++++++++++++++ docs/generated/ast.md | 2 + src/ast.yaml | 2 + src/ast_lower.c | 29 ++++++++++++++ src/ast_ns.c | 19 +++++++++ src/ast_pp.c | 10 +++++ src/ast_prepare.c | 21 ++++++++++ src/pratt_parser.c | 26 ++++++++++++ src/pratt_scanner.c | 1 + src/pratt_scanner.h | 1 + src/syntax_template.c | 9 +++++ 11 files changed, 213 insertions(+) diff --git a/docs/CUT.md b/docs/CUT.md index 7c6494d7..ad33b4e2 100644 --- a/docs/CUT.md +++ b/docs/CUT.md @@ -75,6 +75,42 @@ run-time error. target-b/target-c closure conversion and emitters count lambda arguments generically and do not appear to hard-code failure-continuation arity. +## CPS transform detail + +Inspection of `minlam_cpsTc.c` and `minlam_cpsTk.c` suggests that `cut` +should behave like `amb`, not like `back`. + +- `back` is treated as a leaf control marker. Both `T_c` and `T_k` return it + unchanged. +- `amb` is structurally preserved by CPS. The transform does not assign it any + new operational meaning; instead it recursively CPS-transforms both + branches under the same continuation and rebuilds `MinAmb`. +- That is consistent with the later pipeline split: `back` and `amb` are still + interpreted by `minlam_amb.c`, so the CPS pass should preserve those + markers rather than compiling them away. + +That suggests `cut` should also survive CPS as an explicit control form, with +its operand recursively CPS-transformed but the `cut` node itself preserved for +`minlam_amb.c` to eliminate later. + +Candidate equations: + +```text +T_c(cut e, c) = ((lambda (k) (cut (T_c(e, k)))) c) +T_k(cut e, k) = let c = kToC(k) in cut (T_c(e, c)) +``` + +The important point is not the exact administrative redex shape, but the +control discipline: + +- `cut` should remain a special form after CPS. +- The transformed code for the operand should still run under the same + continuation that `amb` would use. +- The `cut` effect must still happen before evaluation of the transformed + operand. +- The CPS pass should not change the meaning of `back` or `amb`, because the + later `minlam_amb.c` pass still relies on seeing those forms. + ## Work to be done ### Shared work through uncurrying @@ -116,6 +152,9 @@ emission. 1. Thread `cut` through `runCpsTrampolineTc`; this is likely the trickiest branch-specific change. + The current code suggests `cut` should be preserved structurally through + both `T_c` and `T_k`, following the existing `amb` pattern rather than the + `back` pattern. 2. Confirm that the repeated post-split `betaEtaFixedPoint` and `shakeMinExp` passes still behave correctly on the CPS-transformed IR once the shared-path support is in place. @@ -132,6 +171,60 @@ emission. 8. Make the final back continuation report a run-time error when called with `skip = true`. +### Staged implementation plan + +This order is by implementation slice, not by a pure front-to-back or +back-to-front traversal. + +#### Stage 1: shared surface and IR plumbing + +Implement the shared path from parsing through uncurrying. That means scanner +and parser support, AST and syntax-template IR support, lambda conversion, +type checking, desugaring to minlam, and the shared pre-split minlam passes. + +Checkpoint: a small `cut` example should parse, type-check, and survive to the +post-uncurry dump path still as `cut`, without yet needing the CEKF or +target-b/target-c tails to work end-to-end. + +#### Stage 2: reconnect the default CEKF tail + +Once `cut` exists in minlam, reconnect the already surviving ANF, bytecode, +and CEKF runtime support. This is the cheapest end-to-end path to validate +first because the back end largely already exists. + +Checkpoint: the default CEKF path should run targeted `amb` and `cut` +examples, including the unguarded-cut run-time error case. + +#### Stage 3: thread `cut` through CPS + +Extend `runCpsTrampolineTc` so that `cut` remains a special form with the +correct evaluation order and continuation behaviour after CPS conversion. This +is the riskiest part of the work and should be treated as its own slice. + +Checkpoint: the CPS dump should still show a coherent `cut` representation, +with the control effect occurring before evaluation of the argument. + +#### Stage 4: eliminate `cut` in `minlam_amb` + +Change the back-continuation protocol to carry `skip`, make ordinary `back` +use `skip = false`, and rewrite `cut` away by installing a failure +continuation that invokes its parent with `skip = true` before evaluating the +argument expression. + +Checkpoint: after the `amb` dump point, `cut` should be gone from the IR and +the transformed code should express the committed-backtracking behaviour via +the new back-continuation protocol. + +#### Stage 5: validate the post-split target-b/target-c tail + +Audit the repeated and branch-only minExp passes after `minlam_amb.c`, then +validate closure conversion, indexing, and emission for both target-b and +target-c. + +Checkpoint: the target-b and target-c paths should both run targeted `cut` +examples end-to-end, and the final-back `skip = true` case should report the +intended run-time error. + ### Tests 1. Basic commit behaviour. diff --git a/docs/generated/ast.md b/docs/generated/ast.md index 94f89a9d..383d2085 100644 --- a/docs/generated/ast.md +++ b/docs/generated/ast.md @@ -216,6 +216,7 @@ AstExpression --typeOf--> AstTypeOf AstExpression --tuple--> AstExpressions AstExpression --env--> void_ptr AstExpression --structure--> AstStruct +AstExpression --cut--> AstExpression AstExpression --assertion--> AstExpression AstExpression --error--> AstExpression AstExpression --syntaxUse--> AstExprSyntaxUse @@ -247,6 +248,7 @@ AstSyntaxTemplateExpr --print--> AstSyntaxTemplatePrint AstSyntaxTemplateExpr --typeOf--> AstSyntaxTemplateTypeOf AstSyntaxTemplateExpr --tuple--> AstSyntaxTemplateExprs AstSyntaxTemplateExpr --structure--> AstSyntaxTemplateStruct +AstSyntaxTemplateExpr --cut--> AstSyntaxTemplateExpr AstSyntaxTemplateExpr --assertion--> AstSyntaxTemplateExpr AstSyntaxTemplateExpr --error--> AstSyntaxTemplateExpr AstSyntaxTemplateFarg --wildCard--> void_ptr diff --git a/src/ast.yaml b/src/ast.yaml index 8deea200..f005ce53 100644 --- a/src/ast.yaml +++ b/src/ast.yaml @@ -866,6 +866,7 @@ unions: tuple: AstExpressions env: void_ptr structure: AstStruct + cut: AstExpression assertion: AstExpression error: AstExpression syntaxUse: AstExprSyntaxUse @@ -931,6 +932,7 @@ unions: typeOf: AstSyntaxTemplateTypeOf tuple: AstSyntaxTemplateExprs structure: AstSyntaxTemplateStruct + cut: AstSyntaxTemplateExpr assertion: AstSyntaxTemplateExpr error: AstSyntaxTemplateExpr diff --git a/src/ast_lower.c b/src/ast_lower.c index fc058100..d06407eb 100644 --- a/src/ast_lower.c +++ b/src/ast_lower.c @@ -956,6 +956,14 @@ static AstExpression *instantiateTemplateExpr(AstSyntaxTemplateExpr *node, UNPROTECT(save); return result; } + case AST_SYNTAXTEMPLATEEXPR_TYPE_CUT: { + AstExpression *exp = instantiateTemplateExpr( + getAstSyntaxTemplateExpr_Cut(node), context); + int save = PROTECT(exp); + AstExpression *result = newAstExpression_Cut(CPI(node), exp); + UNPROTECT(save); + return result; + } case AST_SYNTAXTEMPLATEEXPR_TYPE_ERROR: { AstExpression *exp = instantiateTemplateExpr( getAstSyntaxTemplateExpr_Error(node), context); @@ -3157,6 +3165,16 @@ static AstExpression *lowerAstExpression(AstExpression *node, } break; } + case AST_EXPRESSION_TYPE_CUT: { + // AstExpression + AstExpression *variant = getAstExpression_Cut(node); + AstExpression *new_variant = lowerAstExpression(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newAstExpression_Cut(CPI(node), new_variant); + } + break; + } case AST_EXPRESSION_TYPE_ERROR: { // AstExpression AstExpression *variant = getAstExpression_Error(node); @@ -3577,6 +3595,17 @@ lowerAstSyntaxTemplateExpr(AstSyntaxTemplateExpr *node, } break; } + case AST_SYNTAXTEMPLATEEXPR_TYPE_CUT: { + // AstSyntaxTemplateExpr + AstSyntaxTemplateExpr *variant = getAstSyntaxTemplateExpr_Cut(node); + AstSyntaxTemplateExpr *new_variant = + lowerAstSyntaxTemplateExpr(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newAstSyntaxTemplateExpr_Cut(CPI(node), new_variant); + } + break; + } case AST_SYNTAXTEMPLATEEXPR_TYPE_ERROR: { // AstSyntaxTemplateExpr AstSyntaxTemplateExpr *variant = getAstSyntaxTemplateExpr_Error(node); diff --git a/src/ast_ns.c b/src/ast_ns.c index 2b6bbac2..e92a2fe5 100644 --- a/src/ast_ns.c +++ b/src/ast_ns.c @@ -2393,6 +2393,16 @@ nsAstSyntaxTemplateExpr(AstSyntaxTemplateExpr *node, VisitorContext context) { } break; } + case AST_SYNTAXTEMPLATEEXPR_TYPE_CUT: { + AstSyntaxTemplateExpr *variant = getAstSyntaxTemplateExpr_Cut(node); + AstSyntaxTemplateExpr *new_variant = + nsAstSyntaxTemplateExpr(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newAstSyntaxTemplateExpr_Cut(CPI(node), new_variant); + } + break; + } case AST_SYNTAXTEMPLATEEXPR_TYPE_ERROR: { AstSyntaxTemplateExpr *variant = getAstSyntaxTemplateExpr_Error(node); AstSyntaxTemplateExpr *new_variant = @@ -2827,6 +2837,15 @@ static AstExpression *nsAstExpression(AstExpression *node, result = rewriteAssertionToCall(new_variant, context); break; } + case AST_EXPRESSION_TYPE_CUT: { + AstExpression *variant = getAstExpression_Cut(node); + AstExpression *new_variant = nsAstExpression(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newAstExpression_Cut(CPI(node), new_variant); + } + break; + } case AST_EXPRESSION_TYPE_ERROR: { AstExpression *variant = getAstExpression_Error(node); AstExpression *new_variant = nsAstExpression(variant, context); diff --git a/src/ast_pp.c b/src/ast_pp.c index 6cbff482..7c43c676 100644 --- a/src/ast_pp.c +++ b/src/ast_pp.c @@ -1201,6 +1201,11 @@ static void ppAstSyntaxTemplateExpr(FILE *out, getAstSyntaxTemplateExpr_Assertion(expression)); fprintf(out, ")"); break; + case AST_SYNTAXTEMPLATEEXPR_TYPE_CUT: + fprintf(out, "cut("); + ppAstSyntaxTemplateExpr(out, getAstSyntaxTemplateExpr_Cut(expression)); + fprintf(out, ")"); + break; case AST_SYNTAXTEMPLATEEXPR_TYPE_ERROR: fprintf(out, "error("); ppAstSyntaxTemplateExpr(out, @@ -1366,6 +1371,11 @@ void ppAstExpression(FILE *out, AstExpression *expr) { ppAstExpression(out, expr->val.assertion); fprintf(out, ")"); break; + case AST_EXPRESSION_TYPE_CUT: + fprintf(out, "cut("); + ppAstExpression(out, expr->val.cut); + fprintf(out, ")"); + break; case AST_EXPRESSION_TYPE_ERROR: fprintf(out, "error("); ppAstExpression(out, expr->val.error); diff --git a/src/ast_prepare.c b/src/ast_prepare.c index b3fba139..3023fb69 100644 --- a/src/ast_prepare.c +++ b/src/ast_prepare.c @@ -2687,6 +2687,16 @@ static AstExpression *prepareAstExpression(AstExpression *node, } break; } + case AST_EXPRESSION_TYPE_CUT: { + // AstExpression + AstExpression *variant = getAstExpression_Cut(node); + AstExpression *new_variant = prepareAstExpression(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newAstExpression_Cut(CPI(node), new_variant); + } + break; + } case AST_EXPRESSION_TYPE_ERROR: { // AstExpression AstExpression *variant = getAstExpression_Error(node); @@ -3126,6 +3136,17 @@ prepareAstSyntaxTemplateExpr(AstSyntaxTemplateExpr *node, } break; } + case AST_SYNTAXTEMPLATEEXPR_TYPE_CUT: { + // AstSyntaxTemplateExpr + AstSyntaxTemplateExpr *variant = getAstSyntaxTemplateExpr_Cut(node); + AstSyntaxTemplateExpr *new_variant = + prepareAstSyntaxTemplateExpr(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newAstSyntaxTemplateExpr_Cut(CPI(node), new_variant); + } + break; + } case AST_SYNTAXTEMPLATEEXPR_TYPE_ERROR: { // AstSyntaxTemplateExpr AstSyntaxTemplateExpr *variant = getAstSyntaxTemplateExpr_Error(node); diff --git a/src/pratt_parser.c b/src/pratt_parser.c index 1860b947..28a671a5 100644 --- a/src/pratt_parser.c +++ b/src/pratt_parser.c @@ -106,6 +106,8 @@ static AstDefinitions *definitions(PrattParser *, HashSymbol *); static AstDefinitions *prattParseLink(PrattParser *, char *, PrattParser **); static AstExpression *back(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); +static AstExpression *cut(PrattRecord *, PrattParser *, AstExpression *, + PrattToken *); static AstExpression *call(PrattRecord *, PrattParser *, AstExpression *, PrattToken *); static AstExpression *makeStruct(PrattRecord *, PrattParser *, AstExpression *, @@ -435,6 +437,7 @@ static PrattParser *makePrattParser(void) { addRecord(table, TOK_IMPORT(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_IN(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_KW_CHAR(), NULL, 0, NULL, 0, NULL, 0); + addRecord(table, TOK_KW_CUT(), cut, 0, NULL, 0, NULL, 0); addRecord(table, TOK_KW_ERROR(), error, 0, NULL, 0, NULL, 0); addRecord(table, TOK_KW_NUMBER(), NULL, 0, NULL, 0, NULL, 0); addRecord(table, TOK_LCURLY(), nestExpr, 0, makeStruct, 0, NULL, 0); @@ -4188,6 +4191,10 @@ static AstLookUpOrSymbol *astFunctionToLos(PrattParser *parser, parserErrorAt(CPI(function), parser, "invalid use of \"back\" as structure name"); return makeLosError(CPI(function)); + case AST_EXPRESSION_TYPE_CUT: + parserErrorAt(CPI(function), parser, + "invalid use of \"cut\" as structure name"); + return makeLosError(CPI(function)); case AST_EXPRESSION_TYPE_FUNCALL: parserErrorAt(CPI(function), parser, "invalid use of function call as structure name"); @@ -4387,6 +4394,10 @@ static AstFarg *astExpressionToFarg(PrattParser *parser, AstExpression *expr) { parserErrorAt(CPI(expr), parser, "invalid use of \"back\" as formal argument"); return newAstFarg_WildCard(CPI(expr)); + case AST_EXPRESSION_TYPE_CUT: + parserErrorAt(CPI(expr), parser, + "invalid use of \"cut\" as formal argument"); + return newAstFarg_WildCard(CPI(expr)); case AST_EXPRESSION_TYPE_FUNCALL: return astFunCallToFarg(parser, expr->val.funCall); case AST_EXPRESSION_TYPE_LOOKUP: @@ -5159,6 +5170,21 @@ static AstExpression *back(PrattRecord *record __attribute__((unused)), return res; } +/** + * @brief parselet triggered by a prefix `cut` token. + */ +static AstExpression *cut(PrattRecord *record, PrattParser *parser, + AstExpression *lhs __attribute__((unused)), + PrattToken *tok __attribute__((unused))) { + ENTER(cut); + AstExpression *toCut = expressionPrecedence(parser, record->prefix.prec); + int save = PROTECT(toCut); + AstExpression *res = newAstExpression_Cut(CPI(toCut), toCut); + LEAVE(cut); + UNPROTECT(save); + return res; +} + /** * @brief parselet triggered by a prefix wildCard (`_`) token. */ diff --git a/src/pratt_scanner.c b/src/pratt_scanner.c index a2c2a4b0..bbc62091 100644 --- a/src/pratt_scanner.c +++ b/src/pratt_scanner.c @@ -74,6 +74,7 @@ TOKFN(IF, "if") TOKFN(IMPORT, "import") TOKFN(IN, "in") TOKFN(KW_CHAR, "char") +TOKFN(KW_CUT, "cut") TOKFN(KW_ERROR, "error") TOKFN(KW_NUMBER, "number") TOKFN(LCURLY, "{") diff --git a/src/pratt_scanner.h b/src/pratt_scanner.h index 97344a1b..d2aed28f 100644 --- a/src/pratt_scanner.h +++ b/src/pratt_scanner.h @@ -83,6 +83,7 @@ HashSymbol *TOK_IF(void); HashSymbol *TOK_IMPORT(void); HashSymbol *TOK_IN(void); HashSymbol *TOK_KW_CHAR(void); +HashSymbol *TOK_KW_CUT(void); HashSymbol *TOK_KW_ERROR(void); HashSymbol *TOK_KW_NUMBER(void); HashSymbol *TOK_LCURLY(void); diff --git a/src/syntax_template.c b/src/syntax_template.c index c99eb3d3..97220eda 100644 --- a/src/syntax_template.c +++ b/src/syntax_template.c @@ -859,6 +859,15 @@ static AstSyntaxTemplateExpr *convertTemplateExpr(AstExpression *expr, switch (expr->type) { case AST_EXPRESSION_TYPE_BACK: return newAstSyntaxTemplateExpr_Back(CPI(expr)); + case AST_EXPRESSION_TYPE_CUT: { + AstSyntaxTemplateExpr *inner = + convertTemplateExpr(getAstExpression_Cut(expr), context); + int save = PROTECT(inner); + AstSyntaxTemplateExpr *result = + newAstSyntaxTemplateExpr_Cut(CPI(expr), inner); + UNPROTECT(save); + return result; + } case AST_EXPRESSION_TYPE_WILDCARD: return newAstSyntaxTemplateExpr_WildCard(CPI(expr)); case AST_EXPRESSION_TYPE_SYMBOL: From 8e4f4baf32209172509178e5589d130d0b5a24bd Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Mon, 18 May 2026 17:08:29 +0100 Subject: [PATCH 3/8] cut lambda conversion in place --- docs/generated/lambda.md | 1 + src/lambda.yaml | 1 + src/lambda_conversion.c | 13 +++++++++++++ src/lambda_desugar.c | 5 +++++ src/lambda_pp.c | 5 +++++ src/lambda_simplfication.c | 3 +++ src/lambda_substitution.c | 4 ++++ 7 files changed, 32 insertions(+) diff --git a/docs/generated/lambda.md b/docs/generated/lambda.md index 1e448f0a..526fdb81 100644 --- a/docs/generated/lambda.md +++ b/docs/generated/lambda.md @@ -109,6 +109,7 @@ LamExp --bigInteger--> MaybeBigInt LamExp --bindings--> LamBindings LamExp --callCC--> LamExp LamExp --character--> character +LamExp --cut--> LamExp LamExp --cond--> LamCond LamExp --constant--> LamConstant LamExp --construct--> LamConstruct diff --git a/src/lambda.yaml b/src/lambda.yaml index 16d0380a..e459d5f6 100644 --- a/src/lambda.yaml +++ b/src/lambda.yaml @@ -379,6 +379,7 @@ unions: bindings: LamBindings # so that ANF normalize can be uniformly typed callCC: LamExp character: character + cut: LamExp cond: LamCond constant: LamConstant construct: LamConstruct diff --git a/src/lambda_conversion.c b/src/lambda_conversion.c index 08d77738..4541ea03 100644 --- a/src/lambda_conversion.c +++ b/src/lambda_conversion.c @@ -67,6 +67,7 @@ static LamExp *convertNest(AstNest *, LamContext *); static LamExp *lamConvert(AstDefinitions *, AstExpressions *, LamContext *); static LamExp *convertSymbol(ParserInfo, HashSymbol *, LamContext *); static LamExp *convertAnnotatedSymbol(AstAnnotatedSymbol *, LamContext *); +static LamExp *convertCut(AstExpression *, LamContext *); #ifdef DEBUG_LAMBDA_CONVERT #include "debugging_on.h" @@ -118,6 +119,14 @@ static LamExp *convertNest(AstNest *nest, LamContext *env) { return result; } +static LamExp *convertCut(AstExpression *value, LamContext *env) { + LamExp *exp = convertExpression(value, env); + int save = PROTECT(exp); + LamExp *result = newLamExp_Cut(CPI(value), exp); + UNPROTECT(save); + return result; +} + /** * @brief Adds constructor information to the lambda context. * @@ -2135,6 +2144,10 @@ static LamExp *convertExpression(AstExpression *expression, LamContext *env) { DEBUG("iff"); result = lamConvertIff(getAstExpression_Iff(expression), env); break; + case AST_EXPRESSION_TYPE_CUT: + DEBUG("cut"); + result = convertCut(getAstExpression_Cut(expression), env); + break; case AST_EXPRESSION_TYPE_PRINT: DEBUG("print"); result = lamConvertPrint(getAstExpression_Print(expression), env); diff --git a/src/lambda_desugar.c b/src/lambda_desugar.c index a704c173..a6f16f81 100644 --- a/src/lambda_desugar.c +++ b/src/lambda_desugar.c @@ -707,6 +707,11 @@ static MinExp *_desugarLamExp(LamExp *node) { result = newMinExp_CallCC(CPI(node), new_callcc); break; } + case LAMEXP_TYPE_CUT: { + cant_happen( + "cut should not reach lambda_desugar before minlam support"); + break; + } case LAMEXP_TYPE_CHARACTER: { result = newMinExp_Character(CPI(node), getLamExp_Character(node)); break; diff --git a/src/lambda_pp.c b/src/lambda_pp.c index eb906ff4..532725bc 100644 --- a/src/lambda_pp.c +++ b/src/lambda_pp.c @@ -130,6 +130,11 @@ void ppLamExp(FILE *out, LamExp *exp) { case LAMEXP_TYPE_CALLCC: ppLamCallCC(out, getLamExp_CallCC(exp)); // LamExp break; + case LAMEXP_TYPE_CUT: + fprintf(out, "(cut "); + ppLamExp(out, getLamExp_Cut(exp)); + fprintf(out, ")"); + break; case LAMEXP_TYPE_PRINT: ppLamPrint(out, getLamExp_Print(exp)); break; diff --git a/src/lambda_simplfication.c b/src/lambda_simplfication.c index 0c682d5f..1205889c 100644 --- a/src/lambda_simplfication.c +++ b/src/lambda_simplfication.c @@ -342,6 +342,9 @@ LamExp *lamPerformSimplifications(LamExp *exp) { case LAMEXP_TYPE_CONSTRUCTOR: case LAMEXP_TYPE_ENV: break; + case LAMEXP_TYPE_CUT: + setLamExp_Cut(exp, lamPerformSimplifications(getLamExp_Cut(exp))); + break; case LAMEXP_TYPE_LAM: exp = performLamSimplifications(getLamExp_Lam(exp)); break; diff --git a/src/lambda_substitution.c b/src/lambda_substitution.c index e8a15869..3d535f99 100644 --- a/src/lambda_substitution.c +++ b/src/lambda_substitution.c @@ -340,6 +340,10 @@ LamExp *lamPerformSubstitutions(LamExp *exp, SymbolMap *substitutions) { case LAMEXP_TYPE_CONSTANT: case LAMEXP_TYPE_CONSTRUCTOR: break; + case LAMEXP_TYPE_CUT: + setLamExp_Cut(exp, lamPerformSubstitutions(getLamExp_Cut(exp), + substitutions)); + break; case LAMEXP_TYPE_LAM: setLamExp_Lam(exp, performLamSubstitutions(getLamExp_Lam(exp), substitutions)); From 574cef7c539f47e08b76530b3ac4a2f0cbd4531f Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Mon, 18 May 2026 17:25:54 +0100 Subject: [PATCH 4/8] cut typecheck in place --- src/inline.c | 3 +++ src/lambda_pp.c | 9 +++++++++ src/tc_analyze.c | 2 ++ 3 files changed, 14 insertions(+) diff --git a/src/inline.c b/src/inline.c index ebe04f0d..340ffc86 100644 --- a/src/inline.c +++ b/src/inline.c @@ -271,6 +271,9 @@ static LamExp *inlineExp(LamExp *x) { case LAMEXP_TYPE_AMB: setLamExp_Amb(x, inlineAmb(getLamExp_Amb(x))); break; + case LAMEXP_TYPE_CUT: + setLamExp_Cut(x, inlineExp(getLamExp_Cut(x))); + break; case LAMEXP_TYPE_TUPLEINDEX: setLamExp_TupleIndex(x, inlineTupleIndex(getLamExp_TupleIndex(x))); break; diff --git a/src/lambda_pp.c b/src/lambda_pp.c index 532725bc..f72347b4 100644 --- a/src/lambda_pp.c +++ b/src/lambda_pp.c @@ -81,6 +81,12 @@ void ppLamVarList(FILE *out, SymbolList *varList) { fprintf(out, ")"); } +void ppLamTypeOf(FILE *out, LamTypeOf *typo) { + fprintf(out, "(typeof "); + ppLamExp(out, typo->exp); + fprintf(out, ")"); +} + void ppLamExp(FILE *out, LamExp *exp) { // sleep(1); if (exp == NULL) { @@ -135,6 +141,9 @@ void ppLamExp(FILE *out, LamExp *exp) { ppLamExp(out, getLamExp_Cut(exp)); fprintf(out, ")"); break; + case LAMEXP_TYPE_TYPEOF: + ppLamTypeOf(out, getLamExp_TypeOf(exp)); + break; case LAMEXP_TYPE_PRINT: ppLamPrint(out, getLamExp_Print(exp)); break; diff --git a/src/tc_analyze.c b/src/tc_analyze.c index b7067060..f8d7c4b0 100644 --- a/src/tc_analyze.c +++ b/src/tc_analyze.c @@ -266,6 +266,8 @@ static TcType *analyzeExp(LamExp *exp, TcEnv *env, TcNg *ng) { return prune(analyzeCond(getLamExp_Cond(exp), env, ng)); case LAMEXP_TYPE_AMB: return prune(analyzeAmb(getLamExp_Amb(exp), env, ng)); + case LAMEXP_TYPE_CUT: + return prune(analyzeExp(getLamExp_Cut(exp), env, ng)); case LAMEXP_TYPE_CHARACTER: return prune(analyzeCharacter()); case LAMEXP_TYPE_BACK: From bf414fe8d165b0a0157b339de03179019ae8921b Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Mon, 18 May 2026 17:36:46 +0100 Subject: [PATCH 5/8] cut minlam transforms mostly in place --- docs/generated/minlam.md | 1 + src/lambda_desugar.c | 5 +++-- src/minlam.yaml | 1 + src/minlam_alphaconvert.c | 10 ++++++++++ src/minlam_beta.c | 9 +++++++++ src/minlam_check.c | 3 +++ src/minlam_curry.c | 9 +++++++++ src/minlam_eta.c | 9 +++++++++ src/minlam_fold.c | 9 +++++++++ src/minlam_freeVars.c | 3 +++ src/minlam_inSafe.c | 1 + src/minlam_pp.c | 6 ++++++ src/minlam_shake.c | 12 +++++++++++- src/minlam_transform.c | 10 ++++++++++ src/minlam_uncurry.c | 10 ++++++++++ 15 files changed, 95 insertions(+), 3 deletions(-) diff --git a/docs/generated/minlam.md b/docs/generated/minlam.md index 0d6d9057..03525c39 100644 --- a/docs/generated/minlam.md +++ b/docs/generated/minlam.md @@ -56,6 +56,7 @@ MinExp --back--> void_ptr MinExp --bigInteger--> MaybeBigInt MinExp --bindings--> MinBindings MinExp --callCC--> MinExp +MinExp --cut--> MinExp MinExp --character--> character MinExp --cond--> MinCond MinExp --done--> int diff --git a/src/lambda_desugar.c b/src/lambda_desugar.c index a6f16f81..0017e2df 100644 --- a/src/lambda_desugar.c +++ b/src/lambda_desugar.c @@ -708,8 +708,9 @@ static MinExp *_desugarLamExp(LamExp *node) { break; } case LAMEXP_TYPE_CUT: { - cant_happen( - "cut should not reach lambda_desugar before minlam support"); + MinExp *new_cut = _desugarLamExp(getLamExp_Cut(node)); + PROTECT(new_cut); + result = newMinExp_Cut(CPI(node), new_cut); break; } case LAMEXP_TYPE_CHARACTER: { diff --git a/src/minlam.yaml b/src/minlam.yaml index 65d00ba5..db76ed51 100644 --- a/src/minlam.yaml +++ b/src/minlam.yaml @@ -199,6 +199,7 @@ unions: bigInteger: MaybeBigInt bindings: MinBindings # so that ANF normalize can be uniformly typed callCC: MinExp # desugared by minlam_cps* + cut: MinExp # preserved until ANF or minlam_amb depending target path character: character cond: MinCond done: int # exit status diff --git a/src/minlam_alphaconvert.c b/src/minlam_alphaconvert.c index cfe6ab2e..9af05193 100644 --- a/src/minlam_alphaconvert.c +++ b/src/minlam_alphaconvert.c @@ -533,6 +533,16 @@ static MinExp *visitMinExp(MinExp *node, MinAlphaEnv *context) { } break; } + case MINEXP_TYPE_CUT: { + // MinExp + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = visitMinExp(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_CHARACTER: { // character break; diff --git a/src/minlam_beta.c b/src/minlam_beta.c index 62dc553d..19cd7e0f 100644 --- a/src/minlam_beta.c +++ b/src/minlam_beta.c @@ -635,6 +635,15 @@ static MinExp *_betaMinExp(MinExp *node, ObjectMap *context) { } break; } + case MINEXP_TYPE_CUT: { + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = _betaMinExp(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_COND: { MinCond *variant = getMinExp_Cond(node); MinCond *new_variant = betaMinCond(variant, context); diff --git a/src/minlam_check.c b/src/minlam_check.c index 9303ec39..45849781 100644 --- a/src/minlam_check.c +++ b/src/minlam_check.c @@ -230,6 +230,9 @@ static void checkMinExpI(MinExp *node, Context *context) { case MINEXP_TYPE_CALLCC: checkMinExpI(getMinExp_CallCC(node), context); break; + case MINEXP_TYPE_CUT: + checkMinExpI(getMinExp_Cut(node), context); + break; case MINEXP_TYPE_COND: checkMinCond(getMinExp_Cond(node), context); break; diff --git a/src/minlam_curry.c b/src/minlam_curry.c index 9a271ffd..7c5a023d 100644 --- a/src/minlam_curry.c +++ b/src/minlam_curry.c @@ -504,6 +504,15 @@ MinExp *curryMinExp(MinExp *node) { } break; } + case MINEXP_TYPE_CUT: { + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = curryMinExp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_CHARACTER: { break; } diff --git a/src/minlam_eta.c b/src/minlam_eta.c index 0883a46b..0b0c6159 100644 --- a/src/minlam_eta.c +++ b/src/minlam_eta.c @@ -574,6 +574,15 @@ MinExp *etaMinExp(MinExp *node) { } break; } + case MINEXP_TYPE_CUT: { + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = etaMinExp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_COND: { MinCond *variant = getMinExp_Cond(node); MinCond *new_variant = etaMinCond(variant); diff --git a/src/minlam_fold.c b/src/minlam_fold.c index 158c49d3..447a92a6 100644 --- a/src/minlam_fold.c +++ b/src/minlam_fold.c @@ -390,6 +390,15 @@ MinExp *foldMinExp(MinExp *node) { } break; } + case MINEXP_TYPE_CUT: { + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = foldMinExp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_COND: { MinCond *variant = getMinExp_Cond(node); MinCond *new_variant = foldMinCond(variant); diff --git a/src/minlam_freeVars.c b/src/minlam_freeVars.c index e9f07ca1..5c896415 100644 --- a/src/minlam_freeVars.c +++ b/src/minlam_freeVars.c @@ -298,6 +298,9 @@ void freeVarsMinExp(MinExp *node, SymbolSet *result, SymbolEnv *context) { case MINEXP_TYPE_SEQUENCE: freeVarsMinExprList(getMinExp_Sequence(node), result, context); break; + case MINEXP_TYPE_CUT: + freeVarsMinExp(getMinExp_Cut(node), result, context); + break; case MINEXP_TYPE_VAR: if (!isSymbolInEnv(context, getMinExp_Var(node))) { setSymbolSet(result, getMinExp_Var(node)); diff --git a/src/minlam_inSafe.c b/src/minlam_inSafe.c index 1c2d7e35..2654f414 100644 --- a/src/minlam_inSafe.c +++ b/src/minlam_inSafe.c @@ -130,6 +130,7 @@ static bool inSafeMinExpInternal(MinExp *node) { case MINEXP_TYPE_AMB: case MINEXP_TYPE_BACK: case MINEXP_TYPE_CALLCC: + case MINEXP_TYPE_CUT: case MINEXP_TYPE_DONE: case MINEXP_TYPE_LETREC: return false; diff --git a/src/minlam_pp.c b/src/minlam_pp.c index 4b2fdf26..b1890474 100644 --- a/src/minlam_pp.c +++ b/src/minlam_pp.c @@ -172,6 +172,12 @@ static void iMinExp(FILE *out, MinExp *exp, int d) { case MINEXP_TYPE_CALLCC: iMinCallCC(out, getMinExp_CallCC(exp), d); break; + case MINEXP_TYPE_CUT: + fprintf(out, "(cut"); + newlineIndent(out, d + 1); + iMinExp(out, getMinExp_Cut(exp), d + 1); + fprintf(out, ")"); + break; case MINEXP_TYPE_LETREC: iMinLetRec(out, getMinExp_LetRec(exp), d); break; diff --git a/src/minlam_shake.c b/src/minlam_shake.c index 4e6bfc8a..fdb57da7 100644 --- a/src/minlam_shake.c +++ b/src/minlam_shake.c @@ -451,6 +451,16 @@ MinExp *shakeMinExp(MinExp *node) { } break; } + case MINEXP_TYPE_CUT: { + // MinExp + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = shakeMinExp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_CHARACTER: { // character break; @@ -544,7 +554,7 @@ MinExp *shakeMinExp(MinExp *node) { break; } default: - cant_happen("unrecognized MinExp type %d", node->type); + cant_happen("unrecognized MinExp type %s", minExpTypeName(node->type)); } UNPROTECT(save); LEAVE(shakeMinExp); diff --git a/src/minlam_transform.c b/src/minlam_transform.c index 3606b9a6..afd2845d 100644 --- a/src/minlam_transform.c +++ b/src/minlam_transform.c @@ -420,6 +420,16 @@ static MinExp *transformMinExp(MinExp *node, Context *c) { result = transformMinExp(getMinExp_CallCC(node), c); break; + case MINEXP_TYPE_CUT: { + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = apply(c, variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } + case MINEXP_TYPE_COND: result = transformMinCond(getMinExp_Cond(node), c); break; diff --git a/src/minlam_uncurry.c b/src/minlam_uncurry.c index 468ab8c0..e24cfa7e 100644 --- a/src/minlam_uncurry.c +++ b/src/minlam_uncurry.c @@ -766,6 +766,16 @@ static MinExp *uncurryMinExp(MinExp *node, IntMap *context) { } break; } + case MINEXP_TYPE_CUT: { + // MinExp + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = uncurryMinExp(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_CHARACTER: { // character break; From 695f2ea2766239253660a1183f759a92259ab44d Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Mon, 18 May 2026 17:59:46 +0100 Subject: [PATCH 6/8] cut cekf path works e2e --- src/anf_normalize.c | 19 +++++++++++++++++++ src/step.c | 36 ++++++++++++++++++++++++++++++++---- 2 files changed, 51 insertions(+), 4 deletions(-) diff --git a/src/anf_normalize.c b/src/anf_normalize.c index 7f7f9fe2..a4da70c2 100644 --- a/src/anf_normalize.c +++ b/src/anf_normalize.c @@ -48,6 +48,7 @@ static AnfExp *normalizeSequence(MinExprList *sequence, AnfExp *tail); static AnfExp *normalizePrim(MinPrimApp *app, AnfExp *tail); static AnfExp *normalizeApply(MinApply *minApply, AnfExp *tail); static AnfExp *normalizeBack(ParserInfo I, AnfExp *tail); +static AnfExp *normalizeCut(MinExp *minExp, AnfExp *tail); static HashSymbol *freshSymbol(); static Aexp *replaceMinExp(MinExp *minExp, MinExpTable *replacements); static AnfExp *letBind(AnfExp *body, MinExpTable *replacements); @@ -107,6 +108,8 @@ static AnfExp *normalize(MinExp *minExp, AnfExp *tail) { return normalizeIff(getMinExp_Iff(minExp), tail); case MINEXP_TYPE_CALLCC: return normalizeCallCc(getMinExp_CallCC(minExp), tail); + case MINEXP_TYPE_CUT: + return normalizeCut(getMinExp_Cut(minExp), tail); case MINEXP_TYPE_LETREC: return normalizeLetRec(getMinExp_LetRec(minExp), tail); case MINEXP_TYPE_MATCH: @@ -239,6 +242,20 @@ static AnfExp *normalizeCallCc(MinExp *minExp, AnfExp *tail) { return res; } +static AnfExp *normalizeCut(MinExp *minExp, AnfExp *tail) { + ENTER(normalizeCut); + AnfExp *cutExp = normalize(minExp, NULL); + int save = PROTECT(cutExp); + Cexp *cexp = newCexp_Cut(CPI(cutExp), newCexpCut(CPI(cutExp), cutExp)); + REPLACE_PROTECT(save, cexp); + AnfExp *exp = wrapCexp(cexp); + REPLACE_PROTECT(save, exp); + exp = wrapTail(exp, tail); + UNPROTECT(save); + LEAVE(normalizeCut); + return exp; +} + static AnfExp *normalizeIff(MinIff *minIff, AnfExp *tail) { ENTER(normalizeIff); MinExpTable *replacements = newMinExpTable(); @@ -642,6 +659,7 @@ static Aexp *replaceMinExp(MinExp *minExp, MinExpTable *replacements) { case MINEXP_TYPE_APPLY: case MINEXP_TYPE_IFF: case MINEXP_TYPE_CALLCC: + case MINEXP_TYPE_CUT: case MINEXP_TYPE_LETREC: case MINEXP_TYPE_MATCH: case MINEXP_TYPE_COND: @@ -670,6 +688,7 @@ static bool minExpIsMinbda(MinExp *val) { case MINEXP_TYPE_APPLY: case MINEXP_TYPE_IFF: case MINEXP_TYPE_CALLCC: + case MINEXP_TYPE_CUT: case MINEXP_TYPE_LETREC: case MINEXP_TYPE_MATCH: case MINEXP_TYPE_COND: diff --git a/src/step.c b/src/step.c index 08750ca6..0b43109d 100644 --- a/src/step.c +++ b/src/step.c @@ -66,6 +66,8 @@ int dump_bytecode_flag = 0; static void step(); static Value lookUp(int frame, int offset); void putCharacter(Character x); +static Location *lookupCurrentLocation(Control control); +static void runtimeSourceError(Control control, const char *message); static CEKF state; @@ -241,6 +243,7 @@ static void inject(ByteCodeArray B, LocationArray *L, void run(ByteCodeArray B, LocationArray *L, BuiltIns *builtIns) { inject(B, L, builtIns); step(); + state.L = NULL; state.E = NULL; state.K = NULL; state.F = NULL; @@ -279,6 +282,32 @@ static inline int readCurrentOffset(void) { return readOffset(&state.B, &state.C); } +static Location *lookupCurrentLocation(Control control) { + if (state.L == NULL || countLocationArray(state.L) == 0) { + return NULL; + } + + Location *result = NULL; + for (Index i = 0; i < countLocationArray(state.L); i++) { + Location *candidate = getLocationArray(state.L, i); + if (candidate->loc > control) { + break; + } + result = candidate; + } + return result; +} + +static void runtimeSourceError(Control control, const char *message) { + Location *location = lookupCurrentLocation(control); + if (location != NULL && location->fileName != NULL) { + eprintf("%s at %s:%d\n", message, location->fileName, location->lineNo); + } else { + eprintf("%s at bytecode offset %04lx\n", message, control); + } + exit(1); +} + // assumes state.C is at the start of the MATCH table // i is the index of the match (i.e. it will be multiplied by the sizeof a word) static inline int readCurrentOffsetAt(int i) { @@ -634,7 +663,6 @@ static void step() { dumpByteCode(stdout, &state.B, state.L); exit(0); } - state.L = NULL; state.C = 0; while (state.C != END_CONTROL) { ++count; @@ -1104,11 +1132,11 @@ static void step() { case BYTECODES_TYPE_CUT: { // discard the current failure continuation DEBUG("CUT"); -#ifdef SAFETY_CHECKS if (state.F == NULL) { - cant_happen("cut with no extant failure continuation"); + runtimeSourceError( + state.C - 1, + "runtime error: cut with no enclosing choice point"); } -#endif state.F = state.F->F; } break; From 1446e95b78e56c05d7f9b0b90ab564dafb4b744c Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Mon, 18 May 2026 18:22:57 +0100 Subject: [PATCH 7/8] cut cps transform done --- src/minlam_cpsTc.c | 30 ++++++++++++++++++++++++++++++ src/minlam_cpsTk.c | 39 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 69 insertions(+) diff --git a/src/minlam_cpsTc.c b/src/minlam_cpsTc.c index 5caba3b0..6b58b559 100644 --- a/src/minlam_cpsTc.c +++ b/src/minlam_cpsTc.c @@ -46,6 +46,7 @@ static MinExp *cpsTcMinCond(MinCond *node, MinExp *c); static MinExp *cpsTcMinMatch(MinMatch *node, MinExp *c); static MinExp *cpsTcMinLetRec(MinLetRec *node, MinExp *c); static MinExp *cpsTcMinAmb(MinAmb *node, MinExp *c); +static MinExp *cpsTcMinCut(MinExp *node, MinExp *c); static MinExp *cpsTcMinExp(MinExp *node, MinExp *c); /* @@ -461,6 +462,21 @@ static MinExp *cpsTcMinAmb(MinAmb *node, MinExp *c) { return result; } +/* + (E.cut_expr(expr)) { + E.cut_expr(T_c(expr, c)) + } +*/ +static MinExp *cpsTcMinCut(MinExp *node, MinExp *c) { + ENTER(cpsTcMinCut); + MinExp *body = cpsTc(getMinExp_Cut(node), c); + int save = PROTECT(body); + MinExp *result = newMinExp_Cut(CPI(node), body); + UNPROTECT(save); + LEAVE(cpsTcMinCut); + return result; +} + /* (lambda (f cc) (f (lambda (x i) (cc x)) @@ -563,6 +579,8 @@ static MinExp *cpsTcMinExp(MinExp *node, MinExp *c) { return node; case MINEXP_TYPE_AMB: return cpsTcMinAmb(getMinExp_Amb(node), c); + case MINEXP_TYPE_CUT: + return cpsTcMinCut(node, c); case MINEXP_TYPE_APPLY: return cpsTcMinApply(getMinExp_Apply(node), c); case MINEXP_TYPE_CALLCC: @@ -737,6 +755,18 @@ CpsWork *cpsStepTc(CpsWork *work) { return next; } + case MINEXP_TYPE_CUT: { + CpsWork *tcWork = makeCpsWork_Tc(getMinExp_Cut(node), c); + int save = PROTECT(tcWork); + MinExp *body = runCpsWorkToResult(tcWork); + PROTECT(body); + MinExp *result = newMinExp_Cut(CPI(node), body); + PROTECT(result); + CpsWork *next = newCpsWork_Result(result); + UNPROTECT(save); + return next; + } + case MINEXP_TYPE_LETREC: { MinLetRec *letrec = getMinExp_LetRec(node); MinBindings *bindings = mapMOverBindings(letrec->bindings); diff --git a/src/minlam_cpsTk.c b/src/minlam_cpsTk.c index 384ff6f5..b1ea4203 100644 --- a/src/minlam_cpsTk.c +++ b/src/minlam_cpsTk.c @@ -46,6 +46,7 @@ static MinExp *cpsTkMinCond(MinCond *node, CpsKont *k); static MinExp *cpsTkMinMatch(MinMatch *node, CpsKont *k); static MinExp *cpsTkMinLetRec(MinLetRec *node, CpsKont *k); static MinExp *cpsTkMinAmb(MinAmb *node, CpsKont *k); +static MinExp *cpsTkMinCut(MinExp *node, CpsKont *k); static MinExp *cpsTkMinExp(MinExp *node, CpsKont *k); static MinExp *packArgsExp(ParserInfo PI, MinExprList *args) { @@ -563,6 +564,28 @@ static MinExp *cpsTkMinAmb(MinAmb *node, CpsKont *k) { return result; } +/* + (E.cut_expr(expr)) { + let + c = kToC(k); + in + E.cut_expr(T_c(expr, c)) + } +*/ +static MinExp *cpsTkMinCut(MinExp *node, CpsKont *k) { + ENTER(cpsTkMinCut); + MinExp *c = kToC(CPI(node), k); + int save = PROTECT(c); + CpsWork *tcWork = makeCpsWork_Tc(getMinExp_Cut(node), c); + PROTECT(tcWork); + MinExp *body = runCpsWorkToResult(tcWork); + PROTECT(body); + MinExp *result = newMinExp_Cut(CPI(node), body); + UNPROTECT(save); + LEAVE(cpsTkMinCut); + return result; +} + /* (E.callCC_expr(e)) { let @@ -600,6 +623,8 @@ static MinExp *cpsTkMinExp(MinExp *node, CpsKont *k) { return node; case MINEXP_TYPE_AMB: return cpsTkMinAmb(getMinExp_Amb(node), k); + case MINEXP_TYPE_CUT: + return cpsTkMinCut(node, k); case MINEXP_TYPE_APPLY: return cpsTkMinApply(node, k); case MINEXP_TYPE_CALLCC: @@ -799,6 +824,20 @@ CpsWork *cpsStepTk(CpsWork *work) { return next; } + case MINEXP_TYPE_CUT: { + MinExp *c = kToC(CPI(node), k); + int save = PROTECT(c); + CpsWork *tcWork = makeCpsWork_Tc(getMinExp_Cut(node), c); + PROTECT(tcWork); + MinExp *body = runCpsWorkToResult(tcWork); + PROTECT(body); + MinExp *result = newMinExp_Cut(CPI(node), body); + PROTECT(result); + CpsWork *next = newCpsWork_Result(result); + UNPROTECT(save); + return next; + } + default: cant_happen("unrecognized MinExp type %s in cpsStepTk", minExpTypeName(node->type)); From bf94ff564bb90845da988fb713026be9a38baa42 Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Mon, 18 May 2026 20:31:57 +0100 Subject: [PATCH 8/8] cut re-implemented on both paths --- Makefile | 2 +- src/emit_b_run.c | 6 +++++ src/main.c | 4 +-- src/minlam_amb.c | 14 +++++++--- src/minlam_emit_c.c | 5 ++++ src/minlam_helper.c | 62 ++++++++++++++++++++++++++++++++++++++++----- src/minlam_helper.h | 6 ++++- 7 files changed, 86 insertions(+), 13 deletions(-) diff --git a/Makefile b/Makefile index d2f46bd9..a2915cb0 100644 --- a/Makefile +++ b/Makefile @@ -320,7 +320,7 @@ test-a: all test-sh: all for t in $(TSTDIR)/sh/*.sh ; do [ -e $$t ] || continue ; echo '***' $$t '***' ; bash $$t || exit 1 ; done - @echo "All A tests passed." + @echo "All sh tests passed." test-fail: all for t in $(TSTDIR)/fn/fail_*.fn ; do echo '***' $$t '***' ; ! ./$(TARGET) --include=fn --assertions-accumulate $$t >/dev/null 2>&1 || exit 1 ; done diff --git a/src/emit_b_run.c b/src/emit_b_run.c index ba4c0600..2b49105d 100644 --- a/src/emit_b_run.c +++ b/src/emit_b_run.c @@ -21,6 +21,8 @@ #include "cekfs.h" #include "minlam_runtime.h" +#include + #ifdef TRACE_BRUN int trace_brun_flag = 0; #define EPRINTF(...) \ @@ -201,6 +203,10 @@ void brun(BLinkedImage *image, BuiltIns *builtins) { } case BBC_TYPE_DONE: { // exit_status EPRINTF("DONE exit=%d\n", inst.a1); + if (inst.a1 == 1) { + fprintf(stderr, + "runtime error: cut with no enclosing choice point\n"); + } exit(inst.a1); // reconsider return instead } case BBC_TYPE_EXT: { // unpacked modifier for the next instruction diff --git a/src/main.c b/src/main.c index e0a17d90..41237faa 100644 --- a/src/main.c +++ b/src/main.c @@ -710,7 +710,7 @@ int main(int argc, char *argv[]) { /////// // CPS /////// - MinExp *done = makeDoneCont(CPI(minExp), 0, true); + MinExp *done = makeDoneCont(CPI(minExp), 0); PROTECT(done); minExp = runCpsTrampolineTc(minExp, done); REPLACE_PROTECT(save2, minExp); @@ -730,7 +730,7 @@ int main(int argc, char *argv[]) { /////// // AMB /////// - MinExp *fail = makeDoneCont(CPI(minExp), 1, false); + MinExp *fail = makeExhaustedCont(CPI(minExp), 0, 1); PROTECT(fail); minExp = ambMinExp(minExp, fail); REPLACE_PROTECT(save2, minExp); diff --git a/src/minlam_amb.c b/src/minlam_amb.c index bba0b72d..4666f964 100644 --- a/src/minlam_amb.c +++ b/src/minlam_amb.c @@ -21,6 +21,7 @@ #include "minlam_amb.h" #include "memory.h" +#include "minlam_helper.h" #include "symbol.h" #ifdef DEBUG_MINLAM_AMB @@ -387,7 +388,7 @@ static MinExp *ambMinAmb(MinAmb *node, MinExp *fail) { MinExp *new_right = ambMinExp(node->right, fail); int save = PROTECT(new_right); // create a new failure continuation - MinExp *fail2 = makeMinExp_Lam(CPI(new_right), NULL, new_right); + MinExp *fail2 = makeChoiceFailCont(new_right, fail); PROTECT(fail2); MinExp *result = ambMinExp(node->left, fail2); UNPROTECT(save); @@ -420,7 +421,7 @@ MinExp *ambMinExp(MinExp *node, MinExp *fail) { break; } case MINEXP_TYPE_BACK: { - result = makeMinExp_Apply(CPI(node), fail, NULL); + result = makeCallFail(CPI(node), fail, 0); break; } case MINEXP_TYPE_BIGINTEGER: { @@ -451,6 +452,13 @@ MinExp *ambMinExp(MinExp *node, MinExp *fail) { } break; } + case MINEXP_TYPE_CUT: { + MinExp *exp = getMinExp_Cut(node); + MinExp *new_fail = makeCutFailCont(fail); + PROTECT(new_fail); + result = ambMinExp(exp, new_fail); + break; + } case MINEXP_TYPE_DONE: { // void_ptr break; @@ -534,7 +542,7 @@ MinExp *ambMinExp(MinExp *node, MinExp *fail) { break; } default: - cant_happen("unrecognized MinExp type %d", node->type); + cant_happen("unrecognized MinExp type %s", minExpTypeName(node->type)); } UNPROTECT(save); diff --git a/src/minlam_emit_c.c b/src/minlam_emit_c.c index 37d21185..d606bc8c 100644 --- a/src/minlam_emit_c.c +++ b/src/minlam_emit_c.c @@ -343,6 +343,11 @@ static void commentER(EC *ctx, char *label, ER *result) { ///////////////// static void emitDone(int status, EC *ctx) { + if (status == 1) { + fprintf(FH(ctx), + "fprintf(stderr, \"runtime error: cut with no enclosing " + "choice point\\n\");\n"); + } fprintf(FH(ctx), "exit(%d);\n", status); } diff --git a/src/minlam_helper.c b/src/minlam_helper.c index a93c003b..eba48b48 100644 --- a/src/minlam_helper.c +++ b/src/minlam_helper.c @@ -33,19 +33,69 @@ SymbolList *minBindingsToSymbolList(MinBindings *bindings) { return this; } -MinExp *makeDoneCont(ParserInfo PI, int status, bool hasArg) { +MinExp *makeDoneCont(ParserInfo PI, int status) { MinExp *body = newMinExp_Done(PI, status); int save = PROTECT(body); - SymbolList *args = NULL; - if (hasArg) { - args = newSymbolList(PI, genSymDollar("k"), NULL); - PROTECT(args); - } + SymbolList *args = newSymbolList(PI, genSymDollar("k"), NULL); + PROTECT(args); + MinExp *lambda = makeMinExp_Lam(PI, args, body); + UNPROTECT(save); + return lambda; +} + +MinExp *makeExhaustedCont(ParserInfo PI, int exhaustedStatus, int cutStatus) { + MinExp *ordinary = newMinExp_Done(PI, exhaustedStatus); + int save = PROTECT(ordinary); + MinExp *cut = newMinExp_Done(PI, cutStatus); + PROTECT(cut); + HashSymbol *skipVar = genSymDollar("skip"); + MinExp *skipExp = newMinExp_Var(PI, skipVar); + PROTECT(skipExp); + MinExp *body = makeMinExp_Iff(PI, skipExp, cut, ordinary); + PROTECT(body); + SymbolList *args = newSymbolList(PI, skipVar, NULL); + PROTECT(args); MinExp *lambda = makeMinExp_Lam(PI, args, body); UNPROTECT(save); return lambda; } +MinExp *makeCallFail(ParserInfo PI, MinExp *fail, int skipValue) { + MinExp *skip = newMinExp_Stdint(PI, skipValue); + int save = PROTECT(skip); + MinExprList *arg = newMinExprList(PI, skip, NULL); + PROTECT(arg); + MinExp *result = makeMinExp_Apply(PI, fail, arg); + UNPROTECT(save); + return result; +} + +MinExp *makeChoiceFailCont(MinExp *body, MinExp *fail) { + MinExp *callFail = makeCallFail(CPI(body), fail, 0); + int save = PROTECT(callFail); + HashSymbol *skipVar = genSymDollar("skip"); + MinExp *skipExp = newMinExp_Var(CPI(body), skipVar); + PROTECT(skipExp); + MinExp *ifThenElse = makeMinExp_Iff(CPI(body), skipExp, callFail, body); + PROTECT(ifThenElse); + SymbolList *newArgs = newSymbolList(CPI(body), skipVar, NULL); + PROTECT(newArgs); + MinExp *fail2 = makeMinExp_Lam(CPI(body), newArgs, ifThenElse); + UNPROTECT(save); + return fail2; +} + +MinExp *makeCutFailCont(MinExp *fail) { + MinExp *callFail = makeCallFail(CPI(fail), fail, 1); + int save = PROTECT(callFail); + HashSymbol *skipVar = genSymDollar("skip"); + SymbolList *newArgs = newSymbolList(CPI(fail), skipVar, NULL); + PROTECT(newArgs); + MinExp *fail2 = makeMinExp_Lam(CPI(fail), newArgs, callFail); + UNPROTECT(save); + return fail2; +} + // returns the the free variables in exp that are in keys // { x in keys : x in FV(exp) } SymbolSet *computeRoots(SymbolSet *keys, MinExp *exp) { diff --git a/src/minlam_helper.h b/src/minlam_helper.h index 5a46ada8..1f60c73f 100644 --- a/src/minlam_helper.h +++ b/src/minlam_helper.h @@ -22,7 +22,11 @@ #include "utils.h" SymbolList *minBindingsToSymbolList(MinBindings *); -MinExp *makeDoneCont(ParserInfo, int, bool); +MinExp *makeDoneCont(ParserInfo, int); +MinExp *makeExhaustedCont(ParserInfo, int, int); +MinExp *makeCallFail(ParserInfo, MinExp *, int); +MinExp *makeChoiceFailCont(MinExp *, MinExp *); +MinExp *makeCutFailCont(MinExp *); SymbolSet *computeRoots(SymbolSet *, MinExp *); SymbolSet *getAllKeys(MinBindings *); SymbolSetMap *buildDependencyGraph(MinBindings *, SymbolSet *);