Commit d88b99f7 authored by mb0's avatar mb0
Browse files

Up.

parent 69c0c21a
......@@ -135,11 +135,12 @@ structure C = struct
fun emitEnvAdd x = PrettyC.call' ("__CLOSURE_ADD", PrettyC.args [x])
fun emitVecLit v =
let
val i = StringCvt.scanString (Int.scan StringCvt.BIN) v
in
str (Int.toString (valOf i))
end
case v of
"" => str "0"
| _ =>
str
(Int.toString
(valOf (StringCvt.scanString (Int.scan StringCvt.BIN) v)))
fun emitStmts stmts = PrettyC.cseq (map emitStmt stmts)
and emitStmt stmt =
......
/* vim:cindent:ts=2:sw=2:expandtab */
#include "dis.h"
......@@ -387,7 +388,3 @@ int main (int argc, char** argv) {
@functions@
/* vim:cindent
* vim:ts=2
* vim:sw=2
* vim:expandtab */
/* vim:cindent:ts=2:sw=2:expandtab */
#ifndef __RUNTIME_H
#define __RUNTIME_H
......@@ -392,7 +393,3 @@ __obj __translate(__obj(*)(__obj,__obj),__obj);
#endif /* __RUNTIME_H */
/* vim:cindent
* vim:ts=2
* vim:sw=2
* vim:expandtab */
......@@ -62,7 +62,11 @@ structure JS0 = struct
fun field f = PropertyName.fromString (Mangle.applyField f)
fun fieldId f = Id.fromString (Mangle.applyField f)
fun tagName tag = Mangle.getStringOfTag tag
fun veclit v = valOf (StringCvt.scanString (Int.scan StringCvt.BIN) v)
fun veclit v =
(* We need to handle empty bit-vector patterns here *)
case v of
"" => 0
| _ => valOf (StringCvt.scanString (Int.scan StringCvt.BIN) v)
val empty = []
fun visitExp (e,acc) =
case e of
......
......@@ -33,7 +33,7 @@ structure CheckDefUse = struct
fun def x =
if Set.member (!census, x)
then raise Fail
(Aux.failWithSymbol "checkDefUse.duplicateDefiniton" x)
(Aux.failWithSymbol "CheckDefUse.duplicateDefiniton" x)
else census := Set.add (!census, x)
fun use x = ()
......@@ -507,6 +507,7 @@ structure Subst = struct
and renameRecs sigma ds =
let
(* TODO: fix renaming of "parallel" declarations *)
val sigma = foldl renameRec sigma ds
in
(sigma,
......@@ -848,7 +849,7 @@ structure Cost = struct
val neverInline = ref Set.empty
fun reset () =
(env:=Set.empty
;allwaysInline:=Set.fromList (map Aux.get
;allwaysInline:=Set.fromList (List.mapPartial Aux.find
[">>",
"return",
">>=",
......@@ -862,6 +863,8 @@ structure Cost = struct
"==",
"not",
"^",
"+",
"-",
"arity0",
"unop",
"binop",
......
......@@ -36,6 +36,7 @@ structure ASTSubst = struct
in
x'
end
fun copyAll xs = map copy xs
fun singleton y x = extend empty y x
......@@ -54,21 +55,23 @@ structure ASTSubst = struct
visitExp sigma thenn,
visitExp sigma elsee)
| CASEexp (e, cs) =>
CASEexp (visitExp sigma e, map (visitCase sigma) cs)
CASEexp
(visitExp sigma e,
map (visitCase sigma) cs)
| BINARYexp (e1, binop, e2) =>
BINARYexp (visitExp sigma e1, binop, visitExp sigma e2)
BINARYexp
(visitExp sigma e1,
binop,
visitExp sigma e2)
| APPLYexp (e, es) =>
APPLYexp (visitExp sigma e, map (visitExp sigma) es)
| RECORDexp fs =>
RECORDexp (map (visitField sigma) fs)
| UPDATEexp fs =>
UPDATEexp (map (visitFieldOpt sigma) fs)
| SEQexp es =>
SEQexp (map (visitSeqexp sigma) es)
| FNexp (x, e) =>
FNexp (x, visitExp sigma e)
| IDexp sym =>
IDexp (apply sigma sym)
APPLYexp
(visitExp sigma e,
map (visitExp sigma) es)
| RECORDexp fs => RECORDexp (map (visitField sigma) fs)
| UPDATEexp fs => UPDATEexp (map (visitFieldOpt sigma) fs)
| SEQexp es => SEQexp (map (visitSeqexp sigma) es)
| FNexp (x, e) => FNexp (x, visitExp sigma e)
| IDexp sym => IDexp (apply sigma sym)
| otherwise => otherwise
and visitRec sigma (f, xs, e) = (f, xs, visitExp sigma e)
......@@ -81,6 +84,85 @@ structure ASTSubst = struct
| ACTIONseqexp e => ACTIONseqexp (visitExp sigma e)
| BINDseqexp (x, e) => BINDseqexp (x, visitExp sigma e)
fun rename t = renameExp empty t
and renameExp sigma t =
case t of
MARKexp t => renameExp sigma (#tree t)
| LETRECexp (ds, e) =>
let
val (sigma,ds) = renameRecs sigma ds
in
LETRECexp (ds, renameExp sigma e)
end
| IFexp (iff, thenn, elsee) =>
IFexp
(renameExp sigma iff,
renameExp sigma thenn,
renameExp sigma elsee)
| CASEexp (e, cs) =>
CASEexp
(renameExp sigma e,
map (renameCase sigma) cs)
| BINARYexp (e1, binop, e2) =>
BINARYexp
(renameExp sigma e1,
binop,
renameExp sigma e2)
| APPLYexp (e, es) =>
APPLYexp
(renameExp sigma e,
map (renameExp sigma) es)
| RECORDexp fs => RECORDexp (map (renameField sigma) fs)
| UPDATEexp fs => UPDATEexp (map (renameFieldOpt sigma) fs)
| SEQexp es => SEQexp (map (renameSeqexp sigma) es)
| FNexp (xs, e) =>
let
val xs' = copyAll xs
val sigma = extendAll sigma xs' xs
in
FNexp (xs', renameExp sigma e)
end
| IDexp sym => IDexp (apply sigma sym)
| otherwise => otherwise
and renameRecs sigma ds =
let
fun renameFn ((f,xs,_),sigma) =
let
val f' = copy f
val xs' = copyAll xs
val sigma = extend sigma f' f
val sigma = extendAll sigma xs' xs
in
sigma
end
val sigma = List.foldl renameFn sigma ds
in
(sigma, map (renameRec sigma) ds)
end
and renameRec sigma (f, xs, e) =
let
val f' = apply sigma f
val xs' = applyAll sigma xs
val e' = renameExp sigma e
in
(f', xs', e')
end
and renameCase sigma (pat, e) = (pat, renameExp sigma e)
and renameField sigma (f, e) = (f, renameExp sigma e)
and renameFieldOpt sigma (f, eOpt) = (f, Option.map (renameExp sigma) eOpt)
and renameSeqexp sigma t =
case t of
MARKseqexp t => renameSeqexp sigma (#tree t)
| ACTIONseqexp e => ACTIONseqexp (renameExp sigma e)
| BINDseqexp (x, e) =>
let
val x' = copy x
val sigma = extend sigma x' x
in
BINDseqexp (x', renameExp sigma e)
end
end
end
......@@ -120,7 +202,7 @@ end = struct
flattenDecodePats
(pats,
SEQexp
[ACTIONseqexp exp',
[ACTIONseqexp (ASTSubst.rename exp'),
ACTIONseqexp exp]))
ds)
in
......
......@@ -19,8 +19,9 @@ end = struct
[] =>
if len <> 0 orelse List.length tok <> 0
then
(print "Retokenize: SKIPPING DECODE DECLARAATION\n"
;NONE) (* TODO: emit warning! *)
(* TODO: Make this a proper warning *)
(print "Retokenize: SKIPPING DECODE DECLARATION\n"
;NONE)
else SOME (rev pats)
| p::ps =>
(case p of
......
granularity = 16
# export = decode
#
# val decode = do
# update@{rd='',rr='',ck='',cs='',cb='',io='',dq=''};
# /
# end
export = decode
val decode =
do update@{rd='',rr='',ck='',cs='',cb='',io='',dq=''};
/
end
type side-effect =
NONE
......@@ -605,7 +605,8 @@ 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
### => see CLC,CLZ,...
#val / ['100101001 s s s 1000'] = unop BCLR cs3
### BLD
### - Bit Load from the T Flag in SREG to a Bit in Register
......@@ -701,7 +702,8 @@ val / ['111100 k k k k k k k 011'] = unop BRVS ck7
### BSET
### - Bit Set in SREG
val / ['100101000 s s s 1000'] = unop BSET cs3
### => see SEC,SEZ,...
#val / ['100101000 s s s 1000'] = unop BSET cs3
### BST
### - Bit Store from Bit in Register to T Flag in SREG
......@@ -853,14 +855,14 @@ 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 / ['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 / ['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)
......@@ -872,7 +874,7 @@ val / ['1110 k k k k d d d d k k k k '] = binop LDI rd4 ck8
### LDS
### - Load Direct from Data Space
val / ['1001000 d d d d d 0000' 'k k k k k k k k k k k k k k k k '] = binop LDS rd5 ck16
val / ['10100 k k k d d d d k k k k '] = binop LDS rd4 ck7
#val / ['10100 k k k d d d d k k k k '] = binop LDS rd4 ck7
### LPM
### - Load Program Memory
......@@ -999,6 +1001,7 @@ val / ['1111111 r r r r r 0 b b b '] = binop SBRS rr5 cb3
### SEC
### - Set Carry Flag
### <=> BSET 0
val / ['1001010000001000'] = nullop SEC
### SEH
......@@ -1015,7 +1018,8 @@ val / ['1001010000101000'] = nullop SEN
### SER
### - Set all Bits in Register
val / ['11101111 d d d d 1111'] = unop SER rd4
### => see LDS Rd,K
#val / ['11101111 d d d d 1111'] = unop SER rd4
### SES
### - Set Signed Flag
......@@ -1049,14 +1053,14 @@ val / ['1001001 r r r r r 1110'] = binop ST (//X DECR) rr5
### ST
### - Store Indirect From Register to Data Space using Index Y
val / ['1000001 r r r r r 1000'] = binop ST (//Y NONE) rr5
#val / ['1000001 r r r r r 1000'] = binop ST (//Y NONE) rr5
val / ['1001001 r r r r r 1001'] = binop ST (//Y INCR) rr5
val / ['1001001 r r r r r 1010'] = binop ST (//Y DECR) rr5
val / ['10 q 0 q q 1 r r r r r 1 q q q '] = binop ST (///Y dq6) rr5
### ST
### - Store Indirect From Register to Data Space using Index Z
val / ['1000001 r r r r r 0000'] = binop ST (//Z NONE) rr5
#val / ['1000001 r r r r r 0000'] = binop ST (//Z NONE) rr5
val / ['1001001 r r r r r 0001'] = binop ST (//Z INCR) rr5
val / ['1001001 r r r r r 0010'] = binop ST (//Z DECR) rr5
val / ['10 q 0 q q 1 r r r r r 0 q q q '] = binop ST (///Z dq6) rr5
......@@ -1064,7 +1068,7 @@ val / ['10 q 0 q q 1 r r r r r 0 q q q '] = binop ST (///Z dq6) rr5
### STS
### - Store Direct to Data Space
val / ['1001001 r r r r r 0000' 'k k k k k k k k k k k k k k k k '] = binop STS ck16 rr5
val / ['10101 k k k r r r r k k k k '] = binop STS ck7 rr4
#val / ['10101 k k k r r r r k k k k '] = binop STS ck7 rr4
### SUB
### - Subtract without Carry
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment