Commit b1780cf7 authored by mb0's avatar mb0
Browse files

Up.

parents f5305f1a 8e7b89af
......@@ -27,7 +27,7 @@ structure Main = struct
ResolveSymbols.run >>= (fn ast =>
ResolveTypeInfo.run ast >>= (fn tInfo =>
TypeInference.run (tInfo, ast) >>= (fn tys =>
return (TextIO.print (TypeInference.showTable tys))
return () (*(TextIO.print (TypeInference.showTable tys))*)
)))
fun runTc fps = let
......
......@@ -131,7 +131,7 @@ fun typeInferencePass (errStrm, ti : TI.type_info, ast) = let
(* define a second traversal that is a full inference of the tree *)
(*local helper function to infer types for a binding group*)
val maxIter = 1
val maxIter = 2
fun checkUsages printWarn (sym, env) =
let
(*val _ = TextIO.print ("***** usages of " ^ SymbolTable.getString(!SymbolTables.varTable, sym) ^ "\n")*)
......
......@@ -88,11 +88,11 @@ end = struct
val compare = compare_clause
end)
type clauses = Clauses.set
structure CS = Clauses
type clauses = CS.set
type units = IntListSet.set
structure US = IntListSet
type units = US.set
type bfun = units * clauses
......@@ -261,8 +261,13 @@ end = struct
List.foldl addClause (addUnits (newUnits, (us, cs))) newClauses
end
fun meet ((us, cs), f) =
CS.foldl addClause (addUnits (US.listItems us,f)) cs
fun meet ((us1, cs1), (us2, cs2)) =
let
val us1 = US.difference (us1,us2)
val cs1 = CS.difference (cs1,cs2)
in
CS.foldl addClause (addUnits (US.listItems us1,(us2, cs2))) cs1
end
(*val b1 = freshBVar ()
val b2 = freshBVar ()
......
......@@ -1189,6 +1189,8 @@ end = struct
fun forceNoInputs (sym, env) = case Scope.lookup (sym,env) of
(_,COMPOUND {ty = SOME (t,bFun), width, uses}) =>
let
val t = case t of (MONAD (r,inp,out)) => inp
| t => t
fun onlyInputs ((true,v),vs) = v :: vs
| onlyInputs ((false,v),vs) = vs
val bVars = texpBVarset onlyInputs (t,[])
......@@ -1283,8 +1285,6 @@ end = struct
fun meetGeneral (env1, env2, directed) =
let
(*val (e1Str', si) = topToStringSI (env1,TVar.emptyShowInfo)
val (e2Str', si) = topToStringSI (env2,si)*)
val substs = unify (env1, env2, emptySubsts)
(*val (scs, cons) = env1
......@@ -1299,6 +1299,12 @@ end = struct
val (env1,env2) = mergeUses (env1, env2)
(*val (e1Str,si) = kappaToStringSI (env1, TVar.emptyShowInfo)
val (e2Str,si) = kappaToStringSI (env2, si)
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 sCons = SC.merge (Scope.getSize state1,Scope.getSize state2)
......@@ -1307,12 +1313,6 @@ end = struct
val (ei, bFunFlow, env) =
applySubsts (substs, emptyExpandInfo, BD.empty, directed, env1, env2)
(*val (e1Str,si) = kappaToStringSI (env1, si)
val (e2Str,si) = kappaToStringSI (env2, si)
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 bVars1 = Scope.getBVars env1
val bVars2 = Scope.getBVars env2
val bVars = BD.union (bVars1,bVars2)
......
......@@ -186,9 +186,26 @@ end = struct
in
List.foldl gV TVar.empty scs
end
fun diff (scs1, scs2) =
let
fun cmp ({terms=(_,v1)::_, const=_},{terms=(_,v2)::_, const=_}) =
TVar.compare (v1,v2)
| cmp _ = raise SizeConstraintBug
fun genDiff (sc1 :: scs1, sc2 :: scs2) =
(case cmp (sc1,sc2) of
LESS => sc1 :: genDiff (scs1, sc2 :: scs2)
| GREATER => genDiff (sc1 :: scs1, scs2)
| EQUAL => genDiff (scs1, scs2)
)
| genDiff (scs1, _) = scs1
in
genDiff (scs1, scs2)
end
fun merge (scs1, scs2) =
let
val scs1 = diff (scs1,scs2)
fun m ([], scs) = scs
| m (eq :: eqs, scs) = case add (eq, scs) of
RESULT (_, scs) => m (eqs, scs)
......@@ -215,6 +232,8 @@ end = struct
fun renameVar sc = case lookupVarSC (v1,sc) of f1 =>
addTermToSC (f1,v2, addTermToSC (~f1,v1, sc))
val renamed = List.map renameVar withVar
val renamed = List.filter
(fn {terms=ts,const} => not (List.null ts)) renamed
in
merge (renamed, retained)
end
......
......@@ -2,16 +2,23 @@ granularity = 16
# export = decode
#
# val decode = do
# update@{rd='',rr='',ck='',cs='',cb='',io=''};
# update@{rd='',rr='',ck='',cs='',cb='',io='',dq=''};
# /
# end
type side-effect =
NONE
| INCR
| DECR
type imm =
IMM3 of 3
| IMM4 of 4
| IMM6 of 6
| IMM7 of 7
| IMM8 of 8
| IMM12 of 12
| IMM16 of 16
| IMM22 of 22
type operand =
......@@ -19,6 +26,8 @@ type operand =
| REGHL of {regh:register,regl:register}
| IOREG of io-register
| IMM of imm
| OPSE of {op:operand,se:side-effect}
| OPDI of {op:operand,imm:imm}
type binop = {first:operand,second:operand}
type unop = {operand:operand}
......@@ -56,7 +65,62 @@ type instruction =
| DES of unop
| EICALL
| EIJMP
| ELPM
| ELPM of binop
| EOR of binop
| FMUL of binop
| FMULS of binop
| FMULSU of binop
| ICALL
| IJMP
| IN of binop
| INC of unop
| JMP of unop
| LAC of binop
| LAS of binop
| LAT of binop
| LD of binop
| LDI of binop
| LDS of binop
| LPM of binop
| LSR of unop
| MOV of binop
| MOVW of binop
| MUL of binop
| MULS of binop
| MULSU of binop
| NEG of unop
| NOP
| OR of binop
| ORI of binop
| OUT of binop
| POP of unop
| PUSH of unop
| RCALL of unop
| RET
| RETI
| RJMP of unop
| ROR of unop
| SBC of binop
| SBCI of binop
| SBI of binop
| SBIC of binop
| SBIS of binop
| SBIW of binop
| SBR of binop
| SBRC of binop
| SBRS of binop
| SEC
| SEH
| SEI
| SEN
| SER of unop
| SES
| SET
| SEV
| SEZ
| SLEEP
| SPM of unop
| ST of binop
type register =
R0
......@@ -125,6 +189,39 @@ type io-register =
| IO29
| IO30
| IO31
| IO32
| IO33
| IO34
| IO35
| IO36
| IO37
| IO38
| IO39
| IO40
| IO41
| IO42
| IO43
| IO44
| IO45
| IO46
| IO47
| IO48
| IO49
| IO50
| IO51
| IO52
| IO53
| IO54
| IO55
| IO56
| IO57
| IO58
| IO59
| IO60
| IO61
| IO62
| IO63
val register-from-bits bits =
case bits of
......@@ -162,46 +259,109 @@ val register-from-bits bits =
| '11111': R31
end
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
'00000': IO0
| '00001': IO1
| '00010': IO2
| '00011': IO3
| '00100': IO4
| '00101': IO5
| '00110': IO6
| '00111': IO7
| '01000': IO8
| '01001': IO9
| '01010': IO10
| '01011': IO11
| '01100': IO12
| '01101': IO13
| '01110': IO14
| '01111': IO15
| '10000': IO16
| '10001': IO17
| '10010': IO18
| '10011': IO19
| '10100': IO20
| '10101': IO21
| '10110': IO22
| '10111': IO23
| '11000': IO24
| '11001': IO25
| '11010': IO26
| '11011': IO27
| '11100': IO28
| '11101': IO29
| '11110': IO30
| '11111': IO31
'000000': IO0
| '000001': IO1
| '000010': IO2
| '000011': IO3
| '000100': IO4
| '000101': IO5
| '000110': IO6
| '000111': IO7
| '001000': IO8
| '001001': IO9
| '001010': IO10
| '001011': IO11
| '001100': IO12
| '001101': IO13
| '001110': IO14
| '001111': IO15
| '010000': IO16
| '010001': IO17
| '010010': IO18
| '010011': IO19
| '010100': IO20
| '010101': IO21
| '010110': IO22
| '010111': IO23
| '011000': IO24
| '011001': IO25
| '011010': IO26
| '011011': IO27
| '011100': IO28
| '011101': IO29
| '011110': IO30
| '011111': IO31
| '100000': IO32
| '100001': IO33
| '100010': IO34
| '100011': IO35
| '100100': IO36
| '100101': IO37
| '100110': IO38
| '100111': IO39
| '101000': IO40
| '101001': IO41
| '101010': IO42
| '101011': IO43
| '101100': IO44
| '101101': IO45
| '101110': IO46
| '101111': IO47
| '110000': IO48
| '110001': IO49
| '110010': IO50
| '110011': IO51
| '110100': IO52
| '110101': IO53
| '110110': IO54
| '110111': IO55
| '111000': IO56
| '111001': IO57
| '111010': IO58
| '111011': IO59
| '111100': IO60
| '111101': IO61
| '111110': IO62
| '111111': IO63
end
val /X = return (REGHL {regh=R27,regl=R26})
val /Y = return (REGHL {regh=R29,regl=R28})
val /Z = return (REGHL {regh=R31,regl=R30})
val r0 = return (REG R0)
val //X se = do
/X <- /X;
return (OPSE {op=(/X),se=se})
end
val //Y se = do
/Y <- /Y;
return (OPSE {op=(/Y),se=se})
end
val //Z se = do
/Z <- /Z;
return (OPSE {op=(/Z),se=se})
end
val ///X imm = do
/X <- /X;
imm <- imm;
return (OPDI {op=(/X),imm=imm})
end
val ///Y imm = do
/Y <- /Y;
imm <- imm;
return (OPDI {op=(/Y),imm=imm})
end
val ///Z imm = do
/Z <- /Z;
imm <- imm;
return (OPDI {op=(/Z),imm=imm})
end
val d ['bit:1'] = do
rd <- query $rd;
update@{rd=rd ^ bit}
......@@ -232,6 +392,11 @@ val b ['bit:1'] = do
update@{cb=cb ^ bit}
end
val q ['bit:1'] = do
dq <- query $dq;
update@{dq=dq ^ bit}
end
val rd5 = do
rd <- query $rd;
update @{rd=''};
......@@ -243,6 +408,18 @@ val rd4 = do
update @{rd=''};
return (REG (register-from-bits ('1' ^ rd)))
end
val rd3 = do
rd <- query $rd;
update @{rd=''};
return (REG (register-from-bits ('10' ^ rd)))
end
val rd2 = do
rd <- query $rd;
update @{rd=''};
return (REG (register-from-bits ('11' ^ rd ^ '0')))
end
val rr5 = do
rr <- query $rr;
......@@ -255,6 +432,12 @@ val rr4 = do
update @{rr=''};
return (REG (register-from-bits ('1' ^ rr)))
end
val rr3 = do
rr <- query $rr;
update @{rr=''};
return (REG (register-from-bits ('10' ^ rr)))
end
val ck4 = do
ck <- query $ck;
......@@ -280,6 +463,18 @@ val ck8 = do
return (IMM (IMM8 ck))
end
val ck12 = do
ck <- query $ck;
update @{ck=''};
return (IMM (IMM12 ck))
end
val ck16 = do
ck <- query $ck;
update @{ck=''};
return (IMM (IMM16 ck))
end
val ck22 = do
ck <- query $ck;
update @{ck=''};
......@@ -298,13 +493,25 @@ val cb3 = do
return (IMM (IMM3 cb))
end
val io = do
val io5 = do
io <- query $io;
update @{io=''};
return (IOREG (io-register-from-bits ('0' ^ io)))
end
val io6 = do
io <- query $io;
update @{io=''};
return (IOREG (io-register-from-bits io))
end
val rd5h-rd5l = do
val dq6 = do
dq <- query $dq;
update @{dq=''};
return (IMM6 dq)
end
val rd2h-rd2l = do
rd <- query $rd;
rd-regl <- return (register-from-bits ('11' ^ rd ^ '0'));
rd-regh <- return (register-from-bits ('11' ^ rd ^ '1'));
......@@ -312,6 +519,22 @@ val rd5h-rd5l = do
return (REGHL {regh=rd-regh,regl=rd-regl})
end
val rd4h-rd4l = do
rd <- query $rd;
rd-regl <- return (register-from-bits (rd ^ '0'));
rd-regh <- return (register-from-bits (rd ^ '1'));
update @{rd=''};
return (REGHL {regh=rd-regh,regl=rd-regl})
end
val rr4h-rr4l = do
rr <- query $rr;
rr-regl <- return (register-from-bits (rr ^ '0'));
rr-regh <- return (register-from-bits (rr ^ '1'));
update @{rr=''};
return (REGHL {regh=rr-regh,regl=rr-regl})
end
val binop cons first second = do
first <- first;
second <- second;
......@@ -337,7 +560,7 @@ 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 rd2h-rd2l ck6
### AND
### - Logical AND
......@@ -385,7 +608,7 @@ val / ['1001010 k k k k k 111 k ' 'k k k k k k k k k k k k k k k k '] = unop CAL
### CBI
### - Clear Bit in I/O Register
val / ['10011000 a a a a a b b b '] = binop CBI io cb3
val / ['10011000 a a a a a b b b '] = binop CBI io5 cb3
### CLC
### - Clear Carry Flag
......@@ -457,5 +680,261 @@ val / ['1001010000011001'] = nullop EIJMP
### ELPM
### - Extended Load Program Memory
val / ['1001010111011000'] = nullop ELPM
# ...
val / ['1001010111011000'] = binop ELPM r0 (//Z NONE)
val / ['1001000 d d d d d 0110'] = binop ELPM rd5 (//Z NONE)
val / ['1001000 d d d d d 0111'] = binop ELPM rd5 (//Z INCR)
### EOR
### - Exclusive OR
val / ['001001 r d d d d d r r r r '] = binop EOR rd5 rr5
### FMUL
### - Fractional Multiply Unsigned
val / ['000000110 d d d 1 r r r '] = binop FMUL rd3 rr3
### FMULS
### - Fractional Multiply Signed
val / ['000000111 d d d 0 r r r '] = binop FMULS rd3 rr3
### FMULSU
### - Fractional Multiply Signed with Unsigned
val / ['000000111 d d d 1 r r r '] = binop FMULSU rd3 rr3
### ICALL
### - Indirect Call to Subroutine
val / ['1001010100001001'] = nullop ICALL
### IJMP
### - Indirect Jump
val / ['1001010000001001'] = nullop IJMP
### IN
### - Load an I/O Location to Register
val / ['10110 a a d d d d d a a a a '] = binop IN rd5 io6
### INC
### - Increment
val / ['1001010 d d d d d 0011'] = unop INC rd5
### JMP
### - Jump
val / ['1001 010 k k k k k 110 k ' 'k k k k k k k k k k k k k k k k '] = unop JMP ck22
### LAC
### - Load And Clear
val / ['1001001 d d d d d 0110'] = binop LAC /Z rd5
### LAS
### - Load And Set
val / ['1001001 d d d d d 0101'] = binop LAS /Z rd5
### LAT
### - Load And Toggle
val / ['1001001 d d d d d 0111'] = binop LAT /Z rd5
### LD
### - Load Indirect from Data Space to Register using Index X
val / ['1001000 d d d d d 1100'] = binop LD rd5 (//X NONE)
val / ['1001000 d d d d d 1101'] = binop LD rd5 (//X INCR)
val / ['1001000 d d d d d 1110'] = binop LD rd5 (//X DECR)
### LD
### - Load Indirect from Data Space to Register using Index Y
val / ['1000000 d d d d d 1000'] = binop LD rd5 (//Y NONE)
val / ['1001000 d d d d d 1001'] = binop LD rd5 (//Y INCR)
val / ['1001000 d d d d d 1010'] = binop LD rd5 (//Y DECR)
val / ['10 q 0 q q 0 d d d d d 1 q q q '] = binop LD rd5 (///Y dq6)
### LD
### - Load Indirect from Data Space to Register using Index Z
val / ['1000000 d d d d d 0000'] = binop LD rd5 (//Z NONE)
val / ['1001000 d d d d d 0001'] = binop LD rd5 (//Z INCR)
val / ['1001000 d d d d d 0010'] = binop LD rd5 (//Z DECR)
val / ['10 q 0 q q 0 d d d d d 0 q q q '] = binop LD rd5 (///Z dq6)