Commit f2e78832 authored by mb0's avatar mb0
Browse files

Merged in simona/mltk (pull request #12)

parents c0708ff4 dea81567
......@@ -8,6 +8,8 @@ structure CompilationMonad : sig
val >> : 'a t * 'b t -> 'b t
val return: 'a -> 'a t
val run: state -> 'a t -> 'a
val mapM : ('a -> 'b t) -> 'a list -> ('b list) t
val fail: 'a t
val getState: state t
val setState: state -> unit t
......@@ -28,28 +30,31 @@ end = struct
type 'answer t = state -> 'answer * state
exception CompilationError
exception Fail of state
fun return v s = (v, s)
fun getState s = (s, s)
fun setState s _ = ((), s)
val getErrorStream: Error.err_stream t = getState
fun fail s = raise CompilationError
fun fail s = raise Fail s
fun aT >>= a2bT = fn s =>
let
val (a, s) =
aT s
handle CompilationError =>
(Error.report (TextIO.stdErr, s)
;raise CompilationError)
val () = Error.report (TextIO.stdErr, s)
in
if Error.anyErrors s
then raise CompilationError
then raise Fail s
else a2bT a s
end
fun const x _ = x
fun aM >> bM = aM >>= const bM
fun mapM f xs = case xs of
[] => return []
| (x :: xs) =>
f x >>= (fn r =>
mapM f xs >>= (fn rs =>
return (r :: rs)))
fun liftErr f a =
getErrorStream >>= (fn errs =>
......@@ -64,8 +69,14 @@ end = struct
val warningAt = liftErr2 Error.warningAt
fun run state action = let
val (b, _) = action state
val (b, s) = action state
handle Fail s =>
(Error.report (TextIO.stdErr, s)
;raise CompilationError)
in
b
if Error.anyErrors s
then (Error.report (TextIO.stdErr, s)
;raise CompilationError)
else b
end
end
......@@ -152,7 +152,7 @@ structure Error :> sig
of LESS => true
| EQUAL => (Position.compare(r1, r2) = LESS)
| GREATER => false))
fun cmp (e1 : error, e2 : error) = lt(#pos e1, #pos e2)
fun cmp (e1 : error, e2 : error) = not (lt(#pos e1, #pos e2))
in
ListMergeSort.sort cmp
end
......@@ -199,8 +199,9 @@ structure Error :> sig
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{file=sm,span=(p1, p2)} => if (p1 = p2)
val pos = (case pos of
NONE => "[no position] "
| SOME{file=sm,span=(p1, p2)} => if (p1 = p2)
then let
val {fileName=SOME f, lineNo, colNo} = SP.sourceLoc sm p1
in
......@@ -234,7 +235,7 @@ structure Error :> sig
pr
end
fun report (outStrm, es as ES{errors, ...}) =
fun report (outStrm, es as ES{errors, numErrors, ...}) =
List.app (printError (outStrm, es)) (sort (!errors))
(* a term marked with a source-map span *)
......
......@@ -58,11 +58,11 @@ end = struct
let
val (eStr,si) = E.kappaToStringSI (env,si)
in
(acc ^ "\n\t" ^ str ^ ": " ^ eStr,si)
(acc ^ "\t" ^ str ^ ": " ^ eStr,si)
end
val (str, si) = List.foldl
genRow
(str ^ msg, TVar.emptyShowInfo) envStrs
(str ^ msg ^ "\n", TVar.emptyShowInfo) envStrs
in
raise S.UnificationFailure str
end
......@@ -79,7 +79,27 @@ end = struct
[] => 0
| (f::fs) => List.foldl checkWidth (String.size f) fs
end
(*convert calls in a decoder pattern into a list of monadic actions*)
fun decsToSeq e [] = e
| decsToSeq e ds = AST.SEQexp
(List.concat (List.map decToSeqDecodepat ds) @ [AST.ACTIONseqexp e])
and decToSeqDecodepat (AST.MARKdecodepat {tree=t, span=s}) =
List.map (fn a => AST.MARKseqexp {tree=a, span=s})
(decToSeqDecodepat t)
| decToSeqDecodepat (AST.TOKENdecodepat tp) =
List.map AST.ACTIONseqexp (decToSeqToken tp)
| decToSeqDecodepat (AST.BITdecodepat bps) =
List.map AST.ACTIONseqexp (List.concat (List.map decToSeqBitpat bps))
and decToSeqToken (AST.MARKtokpat {tree=t, span=s}) =
List.map (fn e => AST.MARKexp {tree=e, span=s}) (decToSeqToken t)
| decToSeqToken (AST.NAMEDtokpat sym) = [AST.IDexp sym]
| decToSeqToken _ = []
and decToSeqBitpat (AST.MARKbitpat {tree=t, span=s}) =
List.map (fn e => AST.MARKexp {tree=e, span=s}) (decToSeqBitpat t)
| decToSeqBitpat (AST.NAMEDbitpat sym) = [AST.IDexp sym]
| decToSeqBitpat _ = []
fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
val sm = ref ([] : symbol_types)
val { tsynDefs, typeDefs, conParents} = ti
......@@ -174,7 +194,7 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
List.filter (fn (s,_) =>
not (SymbolTable.eq_symid(s,sym))) sm)
(!sm) changed
val affectedSyms = E.affectedFunctions (substs,env)
val affectedSyms = E.affectedFunctions (substs,envCall)
val _ = raiseWarning (substs, affectedSyms)
in
(E.SymbolSet.union (unstable, affectedSyms), env)
......@@ -245,6 +265,7 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
case infDecodepat sym (st,env) d of (nArgs, env) => (n+nArgs, env)
val (n,env) = List.foldl pushDecoderBindings (0,env) dec
val env = List.foldl E.pushLambdaVar env args
val rhs = decsToSeq rhs dec
val env = infExp (st,env) rhs
val env = E.reduceToFunction (env, List.length args)
val env = E.return (n,env)
......@@ -395,7 +416,11 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
handle S.UnificationFailure str =>
refineError (str,
" while passing",
List.map (fn e2 => (envArg, "argument " ^ showProg (20, PP.exp, e2))) es2 @
(#1 (List.foldr
(fn (e2,(res,env)) =>
((env, "argument " ^ showProg (20, PP.exp, e2))::res,
E.popKappa env)
) ([], envArg) es2)) @
[(envFun, "to function " ^ showProg (20, PP.exp, e1))])
(*val _ = TextIO.print ("**** app fun,res unified:\n" ^ E.topToString env)*)
val env = E.reduceToResult env
......@@ -684,7 +709,7 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
(ast : SpecAbstractTree.specification)
val toplevelEnv = calcFixpoint (unstable, toplevelEnv)
handle TypeError => toplevelEnv
val _ = TextIO.print ("toplevel environment:\n" ^ E.toString toplevelEnv)
(*val _ = TextIO.print ("toplevel environment:\n" ^ E.toString toplevelEnv)*)
(* check if all exported functions can be run with an empty state *)
fun checkDecoder s sym = case E.forceNoInputs (sym,toplevelEnv) of
......
......@@ -1298,6 +1298,12 @@ end = struct
val env1 = (scs,cons)*)
val (env1,env2) = mergeUses (env1, env2)
val (_, state1) = env1
val (_, state2) = env2
val sCons = SC.merge (Scope.getSize state1,Scope.getSize state2)
val (sCons, substs) = applySizeConstraints (sCons, substs)
val (ei, bFunFlow, env) =
applySubsts (substs, emptyExpandInfo, BD.empty, directed, env1, env2)
......@@ -1306,8 +1312,6 @@ end = struct
val (sStr,si) = showSubstsSI (substs,si)
val kind = if directed then "directed" else "equalizing"
val _ = TextIO.print ("**** meet " ^ kind ^ ":\n" ^ e1Str' ^ "++++ intersected with\n" ^ e2Str')*)
val (_, state1) = env1
val (_, state2) = env2
val bVars1 = Scope.getBVars env1
val bVars2 = Scope.getBVars env2
......@@ -1318,8 +1322,6 @@ end = struct
"\nand\n" ^ BD.showBFun (Scope.getFlow state2) ^
"\nis\n" ^ BD.showBFun bFun ^ "\n")*)
val sCons = SC.merge (Scope.getSize state1,Scope.getSize state2)
val (sCons, substs) = applySizeConstraints (sCons, substs)
val bFun = BD.projectOnto (bVars, bFun)
val bFun = applyExpandInfo ei bFun
......
......@@ -6,7 +6,7 @@ structure Types = struct
type varset = TVar.set
val freshTVar = TVar.freshTVar
val concisePrint = false
val concisePrint = true
datatype texp =
(* a function taking at least one argument *)
......
......@@ -152,7 +152,7 @@ end = struct
(str ^ " " ^ vStr ^ "=" ^ Int.toString(f), si)
end) ("", si) is
in
"result : " ^ scsStr ^ " and " ^ vsStr ^ "instantiated\n"
"result : " ^ scsStr ^ " and" ^ vsStr ^ " instantiated\n"
end
| UNSATISFIABLE => "unsatisfiabilitiy"
| FRACTIONAL => "non-integrality"
......@@ -189,15 +189,18 @@ end = struct
fun merge (scs1, scs2) =
let
(*val (sStr1, si) = toStringSI (scs1, NONE, TVar.emptyShowInfo)
val (sStr2, si) = toStringSI (scs2, NONE, si)
val _ = TextIO.print ("merging " ^ sStr1 ^ " with " ^ sStr2 ^ "\n")*)
fun m ([], scs) = scs
| m (eq :: eqs, scs) = case add (eq, scs) of
RESULT (_, scs) => m (eqs, scs)
| _ => raise SizeConstraintBug
val scs = m (scs1, scs2)
(*val (sStr1, si) = toStringSI (scs1, NONE, TVar.emptyShowInfo)
val (sStr2, si) = toStringSI (scs2, NONE, si)
val (sStr3, si) = toStringSI (scs, NONE, si)
val _ = TextIO.print ("merging " ^ sStr1 ^ " with " ^ sStr2 ^
" resulting in " ^ sStr3 ^ "\n")*)
in
m (scs1, scs2)
scs
end
fun rename (v1,v2,scs) =
......
......@@ -381,10 +381,12 @@ end = struct
let
val vs = SC.getVarset sCons
val (Substs ss) = substsFilter (substs, vs)
fun updateSubsts ((v,WITH_TYPE (CONST c)), (sCons, substs)) =
(case SC.add (SC.equality (v,[],c), sCons) of
SC.RESULT (is,sCons) =>
(sCons, List.foldl (fn ((v,c), substs) =>
(sCons,
List.foldl (fn ((v,c), substs) =>
#1 (addSubst (v,WITH_TYPE (CONST c)) (substs, emptyExpandInfo))
) substs is)
| SC.UNSATISFIABLE => raise UnificationFailure
......@@ -397,6 +399,7 @@ end = struct
| updateSubsts ((v1,WITH_TYPE (VAR (v2,_))), (sCons, substs)) =
(SC.rename (v1,v2,sCons), substs)
| updateSubsts _ = raise SubstitutionBug
in
List.foldl updateSubsts (sCons, substs) ss
end
......
......@@ -48,13 +48,13 @@ end = struct
fun name idx = (if idx>25 then name (Int.div (idx,26)-1) else "") ^
Char.toString (Char.chr (Char.ord #"a"+Int.mod (idx,26)))
fun varToString (TVAR var, tab) = (*(name var, tab)*) case VarMap.find (tab, var) of
SOME str => (str, tab)
| NONE => let
val str = name (VarMap.numItems(tab))
in
(str, VarMap.insert(tab, var, str))
end
fun varToString (TVAR var, tab) = (name var, tab) (*case VarMap.find (tab, var) of
SOME str => (str, tab)
| NONE => let
val str = name (VarMap.numItems(tab))
in
(str, VarMap.insert(tab, var, str))
end *)
structure IntSet = SplaySetFn(struct
type ord_key = int
......
granularity = 8
export = decode
val decode = do
update@{rd='',rr='',ck='',cs='',cb='',io=''};
/
end
datatype imm =
granularity = 16
# export = decode
#
# val decode = do
# update@{rd='',rr='',ck='',cs='',cb='',io=''};
# /
# end
type imm =
IMM3 of 3
| IMM4 of 4
| IMM6 of 6
......@@ -14,7 +14,7 @@ datatype imm =
| IMM8 of 8
| IMM22 of 22
datatype operand =
type operand =
REG of register
| REGHL of {regh:register,regl:register}
| IOREG of io-register
......@@ -22,11 +22,11 @@ datatype operand =
type binop = {first:operand,second:operand}
type unop = {operand:operand}
type nullop = {}
datatype instruction =
type instruction =
ADC of binop
| ADD of binop
| ADIW of binop
| AND of binop
| ANDI of binop
| ASR of unop
......@@ -34,18 +34,19 @@ datatype instruction =
| BLD of binop
| BRBC of binop
| BRBS of binop
| BREAK of nullop
| BREAK
| BSET of unop
| BST of binop
| CALL of unop
| CBI of binop
| CLC of nullop
| CLH of nullop
| CLI of nullop
| CLN of nullop
| CLS of nullop
| CLT of nullop
| CLV of nullop
| CLZ of nullop
| CLC
| CLH
| CLI
| CLN
| CLS
| CLT
| CLV
| CLZ
| COM of unop
| CP of binop
| CPC of binop
......@@ -53,11 +54,11 @@ datatype instruction =
| CPSE of binop
| DEC of unop
| DES of unop
| EICALL of nullop
| EIJMP of nullop
| ELPM of nullop
| EICALL
| EIJMP
| ELPM
datatype register =
type register =
R0
| R1
| R2
......@@ -91,7 +92,7 @@ datatype register =
| R30
| R31
datatype io-register =
type io-register =
IO0
| IO1
| IO2
......@@ -161,9 +162,9 @@ val register-from-bits bits =
| '11111': R31
end
val X = REGHL {regh=REG R27,regl=REG R26}
val Y = REGHL {regh=REG R29,regl=REG R28}
val Z = REGHL {regh=REG R31,regl=REG R30}
val /X = REGHL {regh=R27,regl=R26}
val /Y = REGHL {regh=R29,regl=R28}
val /Z = REGHL {regh=R31,regl=R30}
val io-register-from-bits bits =
case bits of
......@@ -202,151 +203,169 @@ val io-register-from-bits bits =
end
val d ['bit:1'] = do
rd <- (query $rd) ^ bit;
update@{rd=rd}
rd <- query $rd;
update@{rd=rd ^ bit}
end
val r ['bit:1'] = do
rr <- (query $rr) ^ bit;
update@{rr=rr}
rr <- query $rr;
update@{rr=rr ^ bit}
end
val k ['bit:1'] = do
ck <- (query $ck) ^ bit;
update@{ck=ck}
ck <- query $ck;
update@{ck=ck ^ bit}
end
val s ['bit:1'] = do
cs <- (query $cs) ^ bit;
update@{cs=cs}
cs <- query $cs;
update@{cs=cs ^ bit}
end
val a ['bit:1'] = do
io <- (query $io) ^ bit;
update@{io=io}
io <- query $io;
update@{io=io ^ bit}
end
val b ['bit:1'] = do
cb <- query $cb;
update@{cb=cb ^ bit}
end
val rd5 = do
rd <- query $rd;
update @{rd=''};
return (REG (register-from-bits rd))
end
val rd4 = do
rd <- query $rd;
update @{rd=''};
return (REG (register-from-bits ('1' ^ rd)))
end
val rr5 = do
rr <- query $rd;
rr <- query $rr;
update @{rr=''};
return (REG (register-from-bits rr))
end
val rr4 = do
rr <- query $rd;
rr <- query $rr;
update @{rr=''};
return (REG (register-from-bits ('1' ^ rr)))
end
val ck4 = do
ck <- query $ck;
update @{ck=''};
return (IMM (IMM4 ck))
end
val ck6 = do
ck <- query $ck;
update @{ck=''};
return (IMM (IMM6 ck))
end
val ck7 = do
ck <- query $ck;
update @{ck=''};
return (IMM (IMM7 ck))
end
val ck8 = do
ck <- query $ck;
update @{ck=''};
return (IMM (IMM8 ck))
end
val ck22 = do
ck <- query $ck;
update @{ck=''};
return (IMM (IMM22 ck))
end
val cs3 = do
cs <- query $cs;
update @{cs=''};
return (IMM (IMM3 cs))
end
val cb3 = do
cb <- query $cb;
update @{cb=''};
return (IMM (IMM3 cb))
end
val io = do
io <- query $io;
update @{io=''};
return (IOREG (io-register-from-bits io))
end
val rd5h-rd5l = do
rd <- query $rd;
rd-regl <- register-from-bits ('11' ^ rd ^ '0');
rd-regh <- register-from-bits ('11' ^ rd ^ '1');
return (REGHL {regh=rd-regh,regl=rd-regl});
rd-regl <- return (register-from-bits ('11' ^ rd ^ '0'));
rd-regh <- return (register-from-bits ('11' ^ rd ^ '1'));
update @{rd=''};
return (REGHL {regh=rd-regh,regl=rd-regl})
end
val binop cons first second = do
first <- first;
second <- second;
return (cons {first=first, second=second});
return (cons {first=first, second=second})
end
val unop cons operand = do
operand <- operand;
return (cons {operand=operand});
return (cons {operand=operand})
end
val nullop cons = do
return (cons {});
return cons
end
### ADC
### - Add with Carry
val / ['000111' r d d d d d r r r r] = binop ADC rd5 rr5
val / ['000111 r d d d d d r r r r '] = binop ADC rd5 rr5
### ADD
### - Add without Carry
val / ['000011' r d d d d d r r r r] = binop ADD rd5 rr5
val / ['000011 r d d d d d r r r r '] = binop ADD rd5 rr5
### ADIW
### - Add Immediate to Word
val / ['10010110' k k d d k k k k] = binop ADIW rd5h-rd5l ck6
val / ['10010110 k k d d k k k k '] = binop ADIW rd5h-rd5l ck6
### AND
### - Logical AND
val / ['001000' r d d d d d r r r r] = binop AND rd5 rr5
val / ['001000 r d d d d d r r r r '] = binop AND rd5 rr5
### ANDI
### - Logical AND with Immediate
val / ['0111' k k k k d d d d k k k k] = binop ANDI rd4 ck8
val / ['0111 k k k k d d d d k k k k '] = binop ANDI rd4 ck8
### ASR
### - Arithmetic Shift Right
val / ['1001010' d d d d d '0101'] = unop ASR rd5
val / ['1001010 d d d d d 0101'] = unop ASR rd5
### BCLR
### - Bit Clear in SREG
val / ['100101001' s s s '1000'] = unop BCLR cs3
val / ['100101001 s s s 1000'] = unop BCLR cs3
### BLD
### - Bit Load from the T Flag in SREG to a Bit in Register
val / ['1111100' d d d d d '0' b b b] = binop BLD rd5 cb3
val / ['1111100 d d d d d 0 b b b '] = binop BLD rd5 cb3
### BRBC
### - Branch if Bit in SREG is Cleared
val / ['111101' k k k k k k k s s s] = binop BRBC cs3 ck7
val / ['111101 k k k k k k k s s s '] = binop BRBC cs3 ck7
### BRBS
### - Branch if Bit in SREG is Set
val / ['111100' k k k k k k k s s s] = binop BRBS cs3 ck7
val / ['111100 k k k k k k k s s s '] = binop BRBS cs3 ck7
### BREAK
### - Break
......@@ -354,19 +373,19 @@ val / ['1001010110011000'] = nullop BREAK
### BSET
### - Bit Set in SREG
val / ['100101000' s s s '1000'] = unop BSET cs3
val / ['100101000 s s s 1000'] = unop BSET cs3
### BST
### - Bit Store from Bit in Register to T Flag in SREG
val / ['1111101