Skip to content
GitLab
Commit 30e14dc3 authored by Axel Simon's avatar Axel Simon
Browse files

merge

parents 6bbe8649 2dea3bd7
Expand all Hide whitespace changes
Inline Side-by-side
detail/closure/closure.sml
View file @ 30e14dc3
......@@ -33,6 +33,7 @@ structure Closure = struct
and stmt =
LETVAL of Var.v * cval
| LETPRJ of Var.v * field * Var.v
| LETDECON of Var.v * Var.v
| LETUPD of Var.v * Var.v * (field * Var.v) list
| LETREF of Var.v * Var.k * int
| LETENV of Var.k * Var.v list
......@@ -124,6 +125,10 @@ structure Closure = struct
seq
[str "letval", space, var y, is,
str "$", fld f, space, var x]
| LETDECON (y, x) =>
seq
[str "letval", space, var y, is,
str "$$", space, var x]
| LETUPD (y, x, fs) =>
seq
[str "letval", space, var y, is, var x,
......
detail/closure/from-cps.sml
View file @ 30e14dc3
......@@ -204,6 +204,14 @@ end = struct
{flow=flow,
stmts=Clos.LETPRJ (y, f, x)::stmts}
end
| LETDECON (y, x, body) =>
let
val x = Subst.apply sigma x
val {stmts, flow} = convTerm sigma body
in
{flow=flow,
stmts=Clos.LETDECON (y, x)::stmts}
end
| LETUPD (y, x, ds, body) =>
let
val x = Subst.apply sigma x
......
detail/codegen/c0/c0.sml
View file @ 30e14dc3
......@@ -114,7 +114,9 @@ structure C = struct
fun emitField f =
seq [str (Int.toString (VarInfo.toInt f)),
PrettyC.comment (CPS.PP.fld f)]
fun emitDecon x = seq [str "__DECON",lp,PrettyC.var x,rp]
fun emitRecordSelect (f, x) =
seq
[str "__RECORD_SELECT", lp,
......@@ -150,6 +152,8 @@ structure C = struct
LETVAL (x, cval) => emitCVal x cval
| LETPRJ (y, f, x) =>
PrettyC.local1(y, emitRecordSelect (f, x))
| LETDECON (y, x) =>
PrettyC.local1(y, emitDecon x)
| LETREF (y, x, i) =>
PrettyC.local1(y, emitEnvRef (x, i))
| LETUPD (y, x, fs) =>
......
detail/codegen/c0/runtime.h
View file @ 30e14dc3
......@@ -166,6 +166,8 @@
#define __TAGGED_BEGIN(Cname)\
__CHECK_HEAP(1)
#define __DECON(o) (o)->tagged.payload
/** ## Blobs */
#define __BLOB_BEGIN(Cname)\
......
detail/codegen/js0/js0.sml
View file @ 30e14dc3
structure JS0Templates = struct
val runtime = ExpandFile.mkTemplateFromFile "detail/codegen/js0/runtime.js"
......@@ -70,6 +69,7 @@ structure JS0 = struct
| LETREC (ds,t) => visitExp (t, foldl visitRec acc ds)
| LETCONT (ds,t) => visitExp (t, foldl visitCont acc ds)
| LETPRJ (x,f,y,t) => visitExp (t, JSStmt.const (id x, JSExp.select (fieldId f, JSExp.id (id y)))::acc)
| LETDECON (x,y,t) => visitExp (t, JSStmt.const (id x, JSExp.select (Id.fromString "payload", JSExp.id (id y)))::acc)
| LETUPD (x,y,fs,t) =>
(* FIXME: destructive update! *)
let
......@@ -91,7 +91,7 @@ structure JS0 = struct
fun branch (k,xs) = Vector.fromList [JSStmt.return (JSExp.call (id k, map id xs))]
val cs' = List.filter (fn (cs, _) => not (null cs)) cs
val dflt = List.find (fn (cs, _) => null cs) cs
val fatalDflt = Vector.fromList [JSStmt.throw (JSExp.string "Match")]
val fatalDflt = Vector.fromList [JSStmt.throw (JSExp.string "[Match]")]
val dflt =
case dflt of
NONE => fatalDflt
......
detail/common/error.sml
View file @ 30e14dc3
......@@ -6,16 +6,21 @@
* Common infrastructure for error reporting in the Manticore compiler.
*)
structure CurrentSourcemap = struct
val sourcemap = ref (AntlrStreamPos.mkSourcemap())
end
structure Error :> sig
(* logical positions in the input stream *)
type pos = AntlrStreamPos.pos
type span = AntlrStreamPos.span
type span = {file: AntlrStreamPos.sourcemap, span: AntlrStreamPos.span}
type err_stream
(* make an error stream. *)
val mkErrStream : string -> err_stream
val mkErrStream' : unit -> err_stream
val anyErrors : err_stream -> bool
val sourceFile : err_stream -> string
......@@ -58,7 +63,7 @@ structure Error :> sig
structure F = Format
type pos = SP.pos
type span = SP.span
type span = {file: SP.sourcemap, span: SP.span}
datatype severity = WARN | ERR
......@@ -89,6 +94,14 @@ structure Error :> sig
numWarnings = ref 0
}
fun mkErrStream' filename = ES{
srcFile = "<unkown>",
sm = SP.mkSourcemap (),
errors = ref [],
numErrors = ref 0,
numWarnings = ref 0
}
fun anyErrors (ES{numErrors, ...}) = (!numErrors > 0)
fun sourceFile (ES{srcFile, ...}) = srcFile
fun sourceMap (ES{sm, ...}) = sm
......@@ -113,7 +126,7 @@ structure Error :> sig
| Repair.FailureAt tok => ["syntax error at ", tok2str tok]
(* end case *))
in
addErr (es, SOME(pos, pos), String.concat msg)
addErr (es, SOME{file=sourceMap es,span=(pos,pos)}, String.concat msg)
end
(* add error messages to the error stream *)
......@@ -126,14 +139,19 @@ structure Error :> sig
(* sort a list of errors by position in the source file *)
val sort = let
fun fname sm = Option.getOpt (SP.fileName sm 0, "")
fun lt (NONE, NONE) = false
| lt (NONE, _) = true
| lt (_, NONE) = false
| lt (SOME(l1, r1), SOME(l2, r2)) = (case Position.compare(l1, l2)
of LESS => true
| EQUAL => (Position.compare(r1, r2) = LESS)
| GREATER => false
(* end case *))
| lt (SOME{file=f1,span=(l1, r1)}, SOME{file=f2,span=(l2, r2)}) =
(case String.compare (fname f1, fname f2)
of LESS => true
| GREATER => false
| EQUAL =>
(case Position.compare(l1, l2)
of LESS => true
| EQUAL => (Position.compare(r1, r2) = LESS)
| GREATER => false))
fun cmp (e1 : error, e2 : error) = lt(#pos e1, #pos e2)
in
ListMergeSort.sort cmp
......@@ -144,7 +162,8 @@ structure Error :> sig
= UNKNOWN
| LOC of {file : string, l1 : int, c1 : int, l2 : int, c2 : int}
fun location (ES{sm, ...}, (p1, p2) : span) =
(* FIXME *)
fun location (ES{sm, ...}, {span=(p1, p2),...}: span) =
if (p1 = p2)
then let
val {fileName=SOME f, lineNo, colNo} = SP.sourceLoc sm p1
......@@ -160,6 +179,7 @@ structure Error :> sig
else LOC{file=f1, l1=l1, c1=c1, l2=l2, c2=c2}
end
(* FIXME *)
fun position (ES{sm, ...}, p : pos) = let
val {fileName=SOME f, lineNo, colNo} = SP.sourceLoc sm p
in
......@@ -176,11 +196,11 @@ structure Error :> sig
F.STR file, F.INT l1, F.INT c1, F.INT l2, F.INT c2
]
fun printError (outStrm, ES{sm, ...}) = let
fun printError (outStrm, _) = let
fun pr {kind, pos, msg} = let
val kind = (case kind of ERR => "Error" | Warn => "Warning")
val pos = (case pos
of SOME(p1, p2) => if (p1 = p2)
of SOME{file=sm,span=(p1, p2)} => if (p1 = p2)
then let
val {fileName=SOME f, lineNo, colNo} = SP.sourceLoc sm p1
in
......
detail/common/pp.sml
View file @ 30e14dc3
......@@ -18,6 +18,11 @@ structure Pretty = struct
(List.map
(fn (k, i) =>
L.seq [key k, is, item i]) (rev (SymMap.listItemsi t)))
fun symtab {key, item} t =
L.listex "{" "}" ";"
(List.map
(fn (k, i) =>
L.seq [key k, is, item i]) (rev (SymTab.listItemsi t)))
fun symset item t =
L.listex "{" "}" ";"
(List.map item (SymSet.listItems t))
......
detail/cps/cps-opt.sml
View file @ 30e14dc3
This diff is collapsed.
detail/cps/cps.sml
View file @ 30e14dc3
......@@ -22,6 +22,7 @@ structure CPS = struct
| LETREC of recdecl list * term
| LETCONT of contdecl list * term
| LETPRJ of Var.v * field * Var.v * term
| LETDECON of Var.v * Var.v * term
| LETUPD of Var.v * Var.v * (field * Var.v) list * term
| APP of Var.v * Var.c * Var.v list
| CC of Var.c * Var.v list
......@@ -70,6 +71,7 @@ structure CPS = struct
| LETREC (ds, t) => lpTerm (t, visitterm (t, lpRec (ds, seed)))
| LETUPD (_, _, _, t) => lpTerm (t, visitterm (t, seed))
| LETPRJ (_, _, _, t) => lpTerm (t, visitterm (t, seed))
| LETDECON (_, _, t) => lpTerm (t, visitterm (t, seed))
| LETCONT (ds, t) => lpTerm (t, visitterm (t, lpCC (ds, seed)))
| _ => seed
end
......@@ -105,6 +107,7 @@ structure CPS = struct
case body of
LETVAL _ => true
| LETPRJ _ => true
| LETDECON _ => true
| LETUPD _ => true
| _ => false
fun term t =
......@@ -135,6 +138,14 @@ structure CPS = struct
if isLetvalLike body
then term body
else indent 3 (term body)]
| LETDECON (x, v, body) =>
align
[seq
[str "letval", space, var x, is,
str "$$", var v, inn],
if isLetvalLike body
then term body
else indent 3 (term body)]
| LETUPD (x, y, fvs, body) =>
align
[seq
......
detail/cps/from-core.sml
View file @ 30e14dc3
......@@ -191,7 +191,6 @@ end = struct
end
val cps =
trans0
(* TODO: "export" exported symbols as record *)
(LETREC (Builtin.mk()@cs, RECORD (exports spec)))
(fn z => Exp.APP (main, kont, [z]))
in
......@@ -238,9 +237,13 @@ end = struct
| (p, e)::ps =>
let
val k = fresh continuation
val (xs, ks) = transPat p k ks
val (x, ks) = transPat p k ks
fun bindTrans x =
case x of
SOME x => Exp.LETDECON (x, z, trans1 e j)
| _ => trans1 e j
in
trans z ps ((k, xs, trans1 e j)::cps) ks
trans z ps ((k, [], bindTrans x)::cps) ks
end
in
trans0 e (fn z => trans z ps [] [])
......@@ -254,10 +257,6 @@ end = struct
e::es => trans0 e (fn x => trans es (x::xs) k)
| [] => k (rev xs)
in
(* trans0 e1 (fn x1 =>
trans0 e2 (fn x2 =>
Exp.LETCONT ([(k, [x], kappa x)], Exp.APP (x1, k, [x2]))))
*)
trans0 e1 (fn x1 =>
trans es [] (fn xs =>
Exp.LETCONT ([(k, [x], kappa x)], Exp.APP (x1, k, xs))))
......@@ -319,11 +318,6 @@ end = struct
val x = fresh variable
val z = fresh variable
in
(* Exp.LETREC
([(f, k, [x],
Exp.LETPRJ (z, fld, x, Exp.CC (k, z)))],
kappa f) *)
Exp.LETVAL
(f,
Exp.FN
......@@ -351,10 +345,6 @@ end = struct
val j = fresh continuation
val z = fresh variable
in
(* Exp.LETREC
([(f, k, [x],
Exp.LETVAL (y, Exp.INJ (c, x), Exp.CC (k, y)))],
kappa f) *)
Exp.LETVAL
(f,
Exp.FN
......@@ -408,10 +398,17 @@ end = struct
case p of
BIT str => explodePat str
| INT i => [Word.fromLargeInt (IntInf.toLarge i)]
| CON (s, NONE) => [Word.fromInt (SymbolTable.toInt s)]
| _ => []
| CON (tag, _) => [Word.fromInt (SymbolTable.toInt tag)]
| ID _ => []
| WILD => []
fun bndVars p =
case p of
CON (_,SOME x) => SOME x
| ID x => SOME x
| _ => NONE
in
([], (toIdx p, (k, [](*TODO*)))::ks)
(bndVars p, (toIdx p, (k, []))::ks)
end
and trans0rec (n, args, e) =
......@@ -423,7 +420,7 @@ end = struct
let
val x = fresh variable
in
(* TODO *)
(* TODO: value vs (rec) fun *)
(n, k, [x], trans1 (APP (e, [ID x])) k)
end
| args => (n, k, args, trans1 e k)
......@@ -453,9 +450,13 @@ end = struct
(p, e)::ps =>
let
val k = fresh continuation
val (xs, ks) = transPat p k ks
val (x, ks) = transPat p k ks
fun bindTrans x =
case x of
SOME x => Exp.LETDECON (x, z, trans1 e kont)
| _ => trans1 e kont
in
trans z ps ((k, xs, trans1 e kont)::cps) ks
trans z ps ((k, [], bindTrans x)::cps) ks
end
| [] =>
case ks of
......@@ -473,10 +474,6 @@ end = struct
e::es => trans0 e (fn x => trans es (x::xs) k)
| [] => k (rev xs)
in
(* trans0 e1 (fn x1 =>
trans0 e2 (fn x2 =>
Exp.APP (x1, kont, [x2])))
*)
trans0 e1 (fn x1 =>
trans es [] (fn xs =>
Exp.APP (x1, kont, xs)))
......@@ -528,7 +525,6 @@ end = struct
trans0 e (fn z =>
trans y fs ((f, z)::fvs))
in
(* TODO: letval f = \k x. ... *)
Exp.LETVAL
(f,
Exp.FN (k, [x], trans x fs []),
......@@ -541,7 +537,6 @@ end = struct
val x = fresh variable
val z = fresh variable
in
(* TODO: letval f = \k x. ... *)
Exp.LETVAL
(f,
Exp.FN (k, [x], Exp.LETPRJ (z, fld, x, Exp.CC (k, [z]))),
......@@ -564,7 +559,6 @@ end = struct
val x = fresh variable
val y = fresh variable
in
(* TODO: letval f = \k x. ... *)
Exp.LETVAL
(f,
Exp.FN
......
detail/desugar/desugared-tree.sml
View file @ 30e14dc3
......@@ -84,10 +84,23 @@ structure DesugaredTree = struct
and match (p, e) = (pat p, exp e)
and stripMarkPat p =
case p of
MARKpat t => stripMarkPat (#tree t)
| p => p
and pat p =
case p of
MARKpat t => pat (#tree t)
| CONpat (s, p) => Pat.CON (s, Option.map pat p)
| CONpat (s, SOME p) =>
let
val p = stripMarkPat p
in
case p of
IDpat x => Pat.CON (s, SOME x)
| _ => raise Fail "Invalid pattern (too complex...)"
end
| CONpat (s, NONE) => Pat.CON (s, NONE)
| LITpat (INTlit i) => Pat.INT i
| LITpat (VEClit i) => Pat.BIT i
| LITpat _ => raise CM.CompilationError
......
detail/desugar/split-declarations.sml
View file @ 30e14dc3
......@@ -21,7 +21,7 @@ end = struct
type decode = pat list * (exp, (exp * exp) list) Sum.t
type o = (value list * decode list SymMap.map) Spec.t
fun split {span, tree} = let
fun split tree = let
open AST
val granularity = ref (~1: IntInf.int)
val typealias = ref []
......@@ -51,7 +51,6 @@ end = struct
fun splitToplevel spec =
case spec of
MARKdecl t => splitToplevel (#tree t)
| INCLUDEdecl _ => raise CM.CompilationError
| GRANULARITYdecl i => granularity := i
| TYPEdecl d => typealias := d::(!typealias)
| DECODEdecl d => insertDecode d
......
detail/driver/main.sml
View file @ 30e14dc3
......@@ -12,15 +12,14 @@ structure Main = struct
CPSPasses.run >>=
CodegenPasses.run
fun run fp = let
val ins = TextIO.openIn fp
val ers = Error.mkErrStream fp
fun run fps = let
val ers = Error.mkErrStream'()
val () = Controls.set (BasicControl.verbose, 1)
val () = Stats.resetAll()
in
CompilationMonad.run ers (all ins >> return ())
CompilationMonad.run ers (all fps >> return ())
before
(TextIO.closeIn ins; Stats.report())
Stats.report()
end
fun allTc ins =
......@@ -31,14 +30,14 @@ structure Main = struct
return () (*(TextIO.print (TypeInference.showTable tys))*)
)))
fun runTc fp = let
val ins = TextIO.openIn fp
val ers = Error.mkErrStream fp
fun runTc fps = let
val ers = Error.mkErrStream'()
val () = Controls.set (BasicControl.verbose, 1)
val () = Stats.resetAll()
in
CompilationMonad.run ers (allTc ins >> return ())
CompilationMonad.run ers (allTc fps >> return ())
before
TextIO.closeIn ins
Stats.report()
end
end
......@@ -95,10 +94,7 @@ structure Main = struct
else processFile (arg, args)
| _ => usage ()
and processFile (arg, args) =
case (arg, args) of
(file, []) => run file
| _ => usage ()
and processFile (file, files) = run (file::files)
and processOption (arg, args) = let
fun badopt () = bad (concat ["!* ill-formed option: '", arg, "'\n"])
......
detail/parser/mk-ast.sml
View file @ 30e14dc3
......@@ -44,7 +44,6 @@ functor MkAst (Core: AST_CORE) = struct
datatype decl =
MARKdecl of decl mark
| INCLUDEdecl of string
| GRANULARITYdecl of IntInf.int
| TYPEdecl of syn_bind * ty
| DATATYPEdecl of con_bind * (con_bind * ty option) list
......@@ -112,19 +111,18 @@ functor MkAst (Core: AST_CORE) = struct
| STRlit of string
| VEClit of bitpat_lit
type specification = decl list mark
type specification = decl list
structure PP = struct
open Layout Pretty Core
val is = seq [space, str "="]
fun spec (ss:specification) = align (map decl (#tree ss))
fun spec (ss:specification) = align (map decl ss)
and decl t =
case t of
MARKdecl t' => decl (#tree t')
| INCLUDEdecl inc => seq [str "include", space, str inc]
| GRANULARITYdecl i => seq [str "granularity", is, space, int i]
| EXPORTdecl es =>
seq
......
detail/parser/parser.sml
View file @ 30e14dc3
......@@ -3,27 +3,28 @@ structure Parser : sig
(* parse a file; return NONE if there are syntax errors *)
val parseFile: (Error.err_stream * TextIO.instream) -> SpecParseTree.specification option
val parse: string -> SpecParseTree.specification option
val run: TextIO.instream -> SpecParseTree.specification CompilationMonad.t
val parse: string list -> SpecParseTree.specification
val run: string list -> SpecParseTree.specification CompilationMonad.t
val trace: TextIO.outstream * SpecParseTree.specification -> SpecParseTree.specification CompilationMonad.t
end = struct
structure SpecParser = SpecParseFn(SpecLex)
fun lexErr errStrm (pos, msg) = Error.errorAt(errStrm, (pos, pos), msg)
fun lexErr errStrm (pos, msg) =
Error.errorAt(errStrm, {file= !CurrentSourcemap.sourcemap, span=(pos, pos)}, msg)
val parseErr = Error.parseError SpecTokens.toString
fun parseFile (errStrm, file) = let
val lexer = SpecLex.lex (Error.sourceMap errStrm) (lexErr errStrm)
val sm = Error.sourceMap errStrm
val _ = CurrentSourcemap.sourcemap := sm
val lexer = SpecLex.lex sm (lexErr errStrm)
val ins = SpecLex.streamifyInstream file
in
case SpecParser.parse lexer ins of
(SOME pt, _, []) => SOME pt
| (_, _, errs) =>
(List.app (parseErr errStrm) errs
;NONE)
| _ => NONE
end
val parseFile =
......@@ -39,14 +40,30 @@ end = struct
NONE => ()
| SOME x => SpecParseTree.PP.prettyTo (os, x)}
fun run ins = let
fun parse fps = let
fun process fp =
let
val ins = TextIO.openIn fp
val ers = Error.mkErrStream fp
in
parseFile (ers, ins)
before
(TextIO.closeIn ins;
if Error.anyErrors ers
then raise CompilationMonad.CompilationError
else ())
end
in
List.concat (List.mapPartial process fps)
end
fun run fps = let
open CompilationMonad
infix >>=
in
getErrorStream >>= (fn errs =>
case parseFile (errs, ins) of
NONE => fail
| SOME spec => return spec)
case parse fps of
[] => fail
| spec => return spec
end
fun trace (os, spec) = let
......@@ -56,13 +73,4 @@ end = struct
;return spec
end
fun parse fp = let
val ins = TextIO.openIn fp
val ers = Error.mkErrStream fp
val () = Controls.set (BasicControl.verbose, 1)
in
parseFile (ers, ins)
before
(TextIO.closeIn ins; Error.report (TextIO.stdErr, ers))
end
end
detail/parser/spec.g
View file @ 30e14dc3
......@@ -6,7 +6,6 @@
| KW_in ("in")
| KW_do ("do")
| KW_datatype ("datatype")
| KW_include ("include")
| KW_export ("export")
| KW_div ("div")
| KW_else ("else")
......@@ -59,8 +58,10 @@