Skip to content

Commit

Permalink
Change internal representation of module export
Browse files Browse the repository at this point in the history
  • Loading branch information
@minoki
minoki committed Aug 24, 2023
1 parent e63d342 commit 49ae68a
Show file tree
Hide file tree
Showing 6 changed files with 79 additions and 89 deletions.
74 changes: 23 additions & 51 deletions src/cps.sml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -449,8 +449,6 @@ and transformX (ctx : Context, env) (exp : F.Exp) (revDecs : C.Dec list, k : con
}
in doDecs (env, decs, dec :: revDecs)
end
| doDecs (env, F.ExportValue _ :: decs, revDecs) = raise Fail "ExportValue must be the last declaration"
| doDecs (env, F.ExportModule _ :: decs, revDecs) = raise Fail "ExportModule must be the last declaration"
| doDecs (env, F.ESImportDec { pure, specs, moduleName } :: decs, revDecs) = let val dec = C.ESImportDec { pure = pure, specs = List.map (fn (name, vid, _) => (name, vid)) specs, moduleName = moduleName }
in doDecs (env, decs, dec :: revDecs)
end
Expand Down Expand Up @@ -519,55 +517,29 @@ and transformX (ctx : Context, env) (exp : F.Exp) (revDecs : C.Dec list, k : con
| F.TyAppExp (exp, _) => transformX (ctx, env) exp (revDecs, k)
| F.PackExp { payloadTy, exp, packageTy } => transformX (ctx, env) exp (revDecs, k)
| F.BogusExp _ => raise Message.Abort
fun transformDecs (ctx : Context, env) ([] : F.Dec list) (revDecs : C.Dec list, k : C.CVar) : C.CExp
= prependRevDecs (revDecs, C.AppCont { applied = k, args = [] }) (* apply continuation *)
| transformDecs (ctx, env) [F.ExportValue exp] (revDecs, k)
= transform (ctx, env) exp { revDecs = revDecs, resultHint = NONE (* "export"? *) }
(fn (revDecs, v) => prependRevDecs (revDecs, C.AppCont { applied = k, args = [v] }))
| transformDecs (ctx, env) [F.ExportModule items] (revDecs, k)
= foldlCont (fn ((name, exp), (revDecs, acc), cont) => transform (ctx, env) exp { revDecs = revDecs, resultHint = NONE (* name? *) } (fn (revDecs, v) => cont (revDecs, (name, v) :: acc)))
(revDecs, [])
(Vector.foldr (op ::) [] items)
(fn (revDecs, items) =>
let val result = genSym ctx (* "export"? *)
val dec = C.ValDec { exp = C.Record (List.foldl (fn ((name, v), m) => Syntax.LabelMap.insert (m, Syntax.IdentifierLabel name, v)) Syntax.LabelMap.empty items)
, result = SOME result
}
in prependRevDecs (dec :: revDecs, C.AppCont { applied = k, args = [C.Var result] })
end
)
| transformDecs (ctx, env) (dec :: decs) (revDecs, k)
= (case dec of
F.ValDec (vid, _, exp) => transform (ctx, env) exp { revDecs = revDecs, resultHint = SOME vid }
(fn (revDecs, v) => transformDecs (ctx, TypedSyntax.VIdMap.insert (env, vid, v)) decs (revDecs, k))
| F.RecValDec decs' => let val dec = C.RecDec (List.map (fn (vid, _, exp) =>
let val contParam = genContSym ctx
in case stripTyAbs exp of
F.FnExp (param, _, body) => (vid, contParam, [param], transformT (ctx, env) body ([], contParam))
| _ => raise Fail "RecValDec"
end
) decs'
)
in transformDecs (ctx, env) decs (dec :: revDecs, k)
end
| F.UnpackDec (_, _, vid, _, exp) => transform (ctx, env) exp { revDecs = revDecs, resultHint = SOME vid }
(fn (revDecs, v) => transformDecs (ctx, TypedSyntax.VIdMap.insert (env, vid, v)) decs (revDecs, k))
| F.IgnoreDec exp => transform (ctx, env) exp { revDecs = revDecs, resultHint = NONE }
(fn (revDecs, v) => transformDecs (ctx, env) decs (revDecs, k))
| F.DatatypeDec _ => transformDecs (ctx, env) decs (revDecs, k)
| F.ExceptionDec { name, tagName, payloadTy } => let val dec = C.ValDec { exp = C.ExnTag { name = name
, payloadTy = payloadTy
}
, result = SOME tagName
}
in transformDecs (ctx, env) decs (dec :: revDecs, k)
end
| F.ExportValue exp => raise Fail "ExportValue must be the last declaration"
| F.ExportModule _ => raise Fail "ExportModule must be the last declaration"
| F.ESImportDec { pure, specs, moduleName } => let val dec = C.ESImportDec { pure = pure, specs = List.map (fn (name, vid, _) => (name, vid)) specs, moduleName = moduleName }
in transformDecs (ctx, env) decs (dec :: revDecs, k)
end
)
| F.ExitProgram => (case k of
REIFIED k => prependRevDecs (revDecs, C.AppCont { applied = k, args = [] })
| META _ => raise Fail "unexpected META"
)
| F.ExportValue exp => (case k of
REIFIED k => transform (ctx, env) exp { revDecs = revDecs, resultHint = NONE }
(fn (revDecs, v) => prependRevDecs (revDecs, C.AppCont { applied = k, args = [v] }))
| META _ => raise Fail "unexpected META"
)
| F.ExportModule entities => (case k of
REIFIED k => foldlCont (fn ((name, exp), (revDecs, acc), cont) => transform (ctx, env) exp { revDecs = revDecs, resultHint = NONE (* name? *) } (fn (revDecs, v) => cont (revDecs, (name, v) :: acc)))
(revDecs, [])
(Vector.foldr (op ::) [] entities)
(fn (revDecs, items) =>
let val result = genSym ctx (* "export"? *)
val dec = C.ValDec { exp = C.Record (List.foldl (fn ((name, v), m) => Syntax.LabelMap.insert (m, Syntax.IdentifierLabel name, v)) Syntax.LabelMap.empty items)
, result = SOME result
}
in prependRevDecs (dec :: revDecs, C.AppCont { applied = k, args = [C.Var result] })
end
)
| META _ => raise Fail "unexpected META"
)
end
end;

Expand Down
5 changes: 3 additions & 2 deletions src/fprinter.sml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -85,6 +85,9 @@ and doExp prec (F.PrimExp (primOp, types, exps)) = P.Fragment "_prim." :: doPrim
| doExp prec (F.TyAppExp (exp, ty)) = showParen (prec >= 2) (doExp 1 exp @ P.Fragment " [" :: doTy 0 ty @ [P.Fragment "]"])
| doExp prec (F.PackExp { payloadTy, exp, packageTy }) = showParen (prec >= 1) (P.Fragment "_pack (type " :: doTy 0 payloadTy @ P.Fragment ", " :: doExp 0 exp @ P.Fragment ") : " :: doTy 0 packageTy)
| doExp prec (F.BogusExp _) = [P.Fragment "<bogus>"]
| doExp prec F.ExitProgram = [P.Fragment "<exit program>"]
| doExp prec (F.ExportValue exp) = P.Fragment "_export " :: doExp 2 exp
| doExp prec (F.ExportModule fields) = P.Fragment "_export {" :: P.commaSepV (Vector.map (fn (name, exp) => P.Fragment name :: P.Fragment " = " :: doExp 0 exp) fields) @ [P.Fragment "}"]
and doDec (F.ValDec (vid, SOME ty, exp)) = P.Fragment "val " :: P.Fragment (TypedSyntax.print_VId vid) :: P.Fragment " : " :: doTy 0 ty @ P.Fragment " = " :: doExp 0 exp
| doDec (F.ValDec (vid, NONE, exp)) = P.Fragment "val " :: P.Fragment (TypedSyntax.print_VId vid) :: P.Fragment " : _ = " :: doExp 0 exp
| doDec (F.RecValDec binds) = P.Fragment "val rec " :: P.IncreaseIndent 4 :: P.sepBy [P.LineTerminator, P.Indent, P.Fragment "and "] (List.map (fn (vid, ty, exp) => P.Fragment (TypedSyntax.print_VId vid) :: P.Fragment " : " :: doTy 0 ty @ P.Fragment " = " :: doExp 0 exp) binds) @ [P.DecreaseIndent 4]
Expand All @@ -95,8 +98,6 @@ and doDec (F.ValDec (vid, SOME ty, exp)) = P.Fragment "val " :: P.Fragment (Type
) conbinds)) datbinds) @ [P.DecreaseIndent 5]
| doDec (F.ExceptionDec { name, tagName, payloadTy = NONE }) = P.Fragment "exception " :: P.Fragment (TypedSyntax.print_VId tagName) :: []
| doDec (F.ExceptionDec { name, tagName, payloadTy = SOME payloadTy }) = P.Fragment "exception " :: P.Fragment (TypedSyntax.print_VId tagName) :: P.Fragment " of " :: doTy 0 payloadTy
| doDec (F.ExportValue exp) = P.Fragment "_export " :: doExp 0 exp
| doDec (F.ExportModule fields) = P.Fragment "_export {" :: P.commaSepV (Vector.map (fn (name, exp) => P.Fragment name :: P.Fragment " = " :: doExp 0 exp) fields) @ [P.Fragment "}"]
| doDec (F.ESImportDec _) = [P.Fragment "_esImport"]
fun doDecs decs = List.concat (List.map (fn dec => P.Indent :: doDec dec @ [P.LineTerminator]) decs)
end
Loading

0 comments on commit 49ae68a

Please sign in to comment.