diff options
| -rw-r--r-- | Assembler.dcl | 78 | ||||
| -rw-r--r-- | Assembler.icl | 122 | ||||
| -rw-r--r-- | Driver.icl | 3 | ||||
| -rw-r--r-- | GraphStore.icl | 6 | ||||
| -rw-r--r-- | Machine.dcl | 4 |
5 files changed, 208 insertions, 5 deletions
diff --git a/Assembler.dcl b/Assembler.dcl new file mode 100644 index 0000000..f750609 --- /dev/null +++ b/Assembler.dcl @@ -0,0 +1,78 @@ +definition module ABC.Assembler + +from ABC.Def import ::Arity, ::Name, ::NrArgs, ::ArgNr, ::Instruction, ::State +from ABC.AStack import ::ASrc, ::ADst +from ABC.BStack import ::BSrc, ::BDst +from ABC.GraphStore import ::Desc + +:: Label :== String +:: RedLabel :== Label +:: DescLabel :== Label +:: NrInstr :== Int + +:: Assembler :== [Statement] + +:: Statement + = Label Label + | Descriptor DescLabel RedLabel Arity Name + | Br NrInstr + | BrFalse NrInstr + | BrTrue NrInstr + | Dump String + | AddArgs ASrc NrArgs ADst + | Create + | DelArgs ASrc NrArgs ADst + | EqDesc DescLabel ASrc + | EqDescArity DescLabel Arity ASrc + | EqB + | EqB_a Bool ASrc + | EqB_b Bool BSrc + | EqI + | EqI_a Int ASrc + | EqI_b Int BSrc + | Fill DescLabel NrArgs Label ADst + | Fill_a ASrc ADst + | FillB Bool ADst + | FillB_b BSrc ADst + | FillI Int ADst + | FillI_b BSrc ADst + | GetDescArity ASrc + | GetNodeArity ASrc + | Halt + | Jmp Label + | JmpEval + | JmpFalse Label + | JmpTrue Label + | Jsr Label + | JsrEval + | NoOp + | Pop_a Int + | Pop_b Int + | Print String + | PrintSymbol ASrc + | Push_a ASrc + | PushAPEntry ASrc + | PushArg ASrc Arity ArgNr + | PushArg_b ASrc + | PushArgs ASrc Arity ArgNr + | PushArgs_b ASrc + | Push_b Int + | PushB Bool + | PushB_a ASrc + | PushI Int + | PushI_a ASrc + | ReplArgs Arity NrArgs + | ReplArgs_b + | Rtn + | SetEntry Label ADst + | Update_a ASrc ADst + | Update_b BSrc BDst + | AddI + | DecI + | GtI + | IncI + | LtI + | MulI + | SubI + +assemble :: Assembler -> ([Instruction], [Desc]) diff --git a/Assembler.icl b/Assembler.icl new file mode 100644 index 0000000..9de0708 --- /dev/null +++ b/Assembler.icl @@ -0,0 +1,122 @@ +implementation module ABC.Assembler + +import StdEnv + +import ABC.Machine +import ABC.Misc + +assemble :: Assembler -> ([Instruction], [Desc]) +assemble stms = (translate stms loc_counter syms, descTable stms syms) +where + loc_counter = 0 + desc_counter = 0 + syms = collect stms loc_counter desc_counter + +:: SymType = LabSym | DescSym + +instance == SymType +where + (==) LabSym LabSym = True + (==) DescSym DescSym = True + (==) _ _ = False + +instance toString SymType +where + toString LabSym = "label" + toString DescSym = "descriptor" + +:: SymTable :== [(Name, Int, SymType)] + +collect :: Assembler Int Int -> SymTable +collect [] _ _ = [] +collect [Label l :r] lc dc = [(l,lc,LabSym) :collect r lc dc] +collect [Descriptor dl rl _ _:r] lc dc = [(dl,dc,DescSym):collect r lc (dc+1)] +collect [_ :r] lc dc = collect r (lc+1) dc + +lookup :: Label SymType SymTable -> Int +lookup l t [] = abortn ("label " <+ l <+ " not defined as " <+ t) +lookup l t [(name,n,type):r] +| l == name && t == type = n +| otherwise = lookup l t r + +descTable :: Assembler SymTable -> [Desc] +descTable [] _ = [] +descTable [Descriptor dl e a n:r] syms = [Desc ap_addr a n:descTable r syms] +where ap_addr = lookup e LabSym syms +descTable [_ :r] syms = descTable r syms + +translate :: Assembler Int SymTable -> [Instruction] +translate [] _ _ = [] +translate [Label _ :r] lc syms = translate r lc syms +translate [Descriptor _ _ _ _:r] lc syms = translate r lc syms +translate [stm :r] lc syms + = [trans stm lc syms:translate r (lc+1) syms] +where + trans :: Statement Int SymTable -> Instruction + trans (Br n) lc _ = jmp (lc+n+1) + trans (BrFalse n) lc _ = jmp_false (lc+n+1) + trans (BrTrue n) lc _ = jmp_true (lc+n+1) + trans (Dump s) _ _ = dump s + trans (AddArgs s n d) _ _ = add_args s n d + trans Create _ _ = create + trans (DelArgs s n d) _ _ = del_args s n d + trans (EqDesc dl s) _ syms = eq_desc daddr s + where daddr = (lookup dl DescSym syms) + trans (EqDescArity dl a s) _ syms = eq_desc_arity daddr a s + where daddr = (lookup dl DescSym syms) + trans EqB _ _ = eqB + trans (EqB_a b s) _ _ = eqB_a b s + trans (EqB_b b s) _ _ = eqB_b b s + trans EqI _ _ = eqI + trans (EqI_a i s) _ _ = eqI_a i s + trans (EqI_b i s) _ _ = eqI_b i s + trans (Fill l n e d) _ syms = fill daddr n eaddr d + where (daddr,eaddr) = (lookup l DescSym syms, lookup e LabSym syms) + trans (Fill_a s d) _ _ = fill_a s d + trans (FillB b d) _ _ = fillB b d + trans (FillB_b s d) _ _ = fillB_b s d + trans (FillI i d) _ _ = fillI i d + trans (FillI_b s d) _ _ = fillI_b s d + trans (GetDescArity s) _ _ = get_desc_arity s + trans (GetNodeArity s) _ _ = get_node_arity s + trans Halt _ _ = halt + trans (Jmp l) _ syms = jmp addr + where addr = lookup l LabSym syms + trans JmpEval _ _ = jmp_eval + trans (JmpFalse l) _ syms = jmp_false addr + where addr = lookup l LabSym syms + trans (JmpTrue l) _ syms = jmp_true addr + where addr = lookup l LabSym syms + trans (Jsr l) _ syms = jsr addr + where addr = lookup l LabSym syms + trans JsrEval _ _ = jsr_eval + trans NoOp _ _ = no_op + trans (Pop_a n) _ _ = pop_a n + trans (Pop_b n) _ _ = pop_b n + trans (Print s) _ _ = print s + trans (PrintSymbol s) _ _ = print_symbol s + trans (Push_a s) _ _ = push_a s + trans (PushAPEntry s) _ _ = push_ap_entry s + trans (PushArg s a n) _ _ = push_arg s a n + trans (PushArg_b s) _ _ = push_arg_b s + trans (PushArgs s a n) _ _ = push_args s a n + trans (PushArgs_b s) _ _ = push_args_b s + trans (Push_b i) _ _ = push_b i + trans (PushB b) _ _ = pushB b + trans (PushB_a s) _ _ = pushB_a s + trans (PushI i) _ _ = pushI i + trans (PushI_a s) _ _ = pushI_a s + trans (ReplArgs a n) _ _ = repl_args a n + trans ReplArgs_b _ _ = repl_args_b + trans Rtn _ _ = rtn + trans (SetEntry l d) _ syms = set_entry addr d + where addr = lookup l LabSym syms + trans (Update_a s d) _ _ = update_a s d + trans (Update_b s d) _ _ = update_b s d + trans AddI _ _ = addI + trans DecI _ _ = decI + trans GtI _ _ = gtI + trans IncI _ _ = incI + trans LtI _ _ = ltI + trans MulI _ _ = mulI + trans SubI _ _ = subI @@ -1,6 +1,6 @@ implementation module ABC.Driver -import StdEnv +import StdEnv, StdDebug import ABC.Machine @@ -18,6 +18,7 @@ boot (prog,descs) fetch_cycle :: State -> State fetch_cycle st=:{pc,program} +//# pc = trace_n pc pc | pc_end pc = st | otherwise = fetch_cycle (currinstr {st & pc=pc`}) where diff --git a/GraphStore.icl b/GraphStore.icl index 6f2a2e0..0f32994 100644 --- a/GraphStore.icl +++ b/GraphStore.icl @@ -40,15 +40,15 @@ where show_nd :: Node [Desc] -> String show_nd (Basic _ e b) _ = e <+ " " <+ b - show_nd (Node d e a) ds = d_name (ds_get d ds) <+ " " <+ e <+ " " <+ a + show_nd (Node d e a) ds = d_name (ds_get d ds) <+ " " <+ e <+ " [" <++ (",", a) <+ "]" show_nd Empty _ = "Empty" gs_get :: NodeId GraphStore -> Node -gs_get i {nodes} = get i nodes +gs_get i {nodes,free} = get (i-free-1) nodes where get :: NodeId [Node] -> Node get 0 [n:_] = n - get _ [] = abortn "gs_get: index too large" + get _ [] = abortn ("gs_get: index " <+ i <+ " too large for " <+ length nodes <+ " node(s)") get i [_:s] = get (i-1) s gs_init :: GraphStore diff --git a/Machine.dcl b/Machine.dcl index e71147b..de98de2 100644 --- a/Machine.dcl +++ b/Machine.dcl @@ -12,4 +12,6 @@ import ABC.IO, ABC.Instructions, - ABC.Driver + ABC.Driver, + + ABC.Assembler |