never executed always true always false
1 module HelVM.HelMA.Automaton.Combiner.CPU where
2
3 import HelVM.HelMA.Automaton.Combiner.ALU
4
5 import HelVM.HelMA.Automaton.Instruction
6 import HelVM.HelMA.Automaton.Instruction.Extras.Patterns
7 import HelVM.HelMA.Automaton.Instruction.Groups.CFInstruction
8
9 import HelVM.HelIO.Containers.MTIndexSafe
10 import HelVM.HelIO.Control.Safe
11
12 import Control.Type.Operator
13
14 import qualified Data.Vector as Vector
15
16 runCFI ∷ (ALU m ll element , Show element) ⇒ CFInstruction → CentralProcessingStep ll m
17 runCFI (Mark _) = pure
18 runCFI (Branch o t) = branchInstruction t o
19 runCFI (Labeled o i) = labeledInstruction i o
20 runCFI Return = popAddress
21
22 popAddress ∷ ALU m ll element ⇒ CentralProcessingMemory ll → m $ CentralProcessingMemory ll
23 popAddress (CPM (CM il _ (IS (a : is))) s) = pure $ CPM (CM il a $ IS is) s
24 popAddress (CPM (CM il _ (IS [] )) _) = liftErrorWithTupleList "Empty Return Stack" [("il" , show il)]
25
26 --
27
28 branchInstruction ∷ (ALU m ll element , Show element) ⇒ BranchTest → BranchOperand → CentralProcessingStep ll m
29 branchInstruction t BSwapped = branchSwappedInstruction t
30 branchInstruction t BTop = branchTopInstruction t
31 branchInstruction t (BImmediate l) = branchImmediateInstruction t l
32 branchInstruction t (BArtificial l) = branchArtificialInstruction t l
33
34 branchSwappedInstruction ∷ (ALU m ll element , Show element) ⇒ BranchTest → CentralProcessingStep ll m
35 branchSwappedInstruction t cpm = appendError "CPM.branchSwappedInstruction" $ build =<< cpmPop2 cpm where
36 build (e , l , cpm') = branch t e (findAddressForNaturalLabel l (cpmProgram cpm')) cpm'
37
38 branchTopInstruction ∷ (ALU m ll element , Show element) ⇒ BranchTest → CentralProcessingStep ll m
39 branchTopInstruction t cpm = appendError "CPM.branchTopInstruction" $ build =<< cpmPop2 cpm where
40 build (l , e , cpm') = branch t e (findAddressForNaturalLabel l (cpmProgram cpm')) cpm'
41
42 branchImmediateInstruction ∷ (ALU m ll element , DynamicLabel l) ⇒ BranchTest → l → CentralProcessingStep ll m
43 branchImmediateInstruction t l cpm = appendError "CPM.branchImmediateInstruction" $ build =<< cpmPop1 cpm where
44 build (e , cpm') = branch t e (findAddressForNaturalLabel l (cpmProgram cpm')) cpm'
45
46 branchArtificialInstruction ∷ (ALU m ll element) ⇒ BranchTest → Label → CentralProcessingStep ll m
47 branchArtificialInstruction t l cpm = appendError "CPM.branchArtificialInstruction" $ build =<< cpmPop1 cpm where
48 build (e , cpm') = branch t e (findAddressForArtificialLabel l (cpmProgram cpm')) cpm'
49
50 branch ∷ (ALU m ll element) ⇒ BranchTest → element → m InstructionCounter → CentralProcessingStep ll m
51 branch t e icM cpm
52 | isJump t e = flip jump cpm <$> icM
53 | otherwise = pure cpm
54
55 --
56
57 labeledInstruction ∷ (ALU m ll element , Show element) ⇒ LabelOperation → LabelOperand → CentralProcessingStep ll m
58 labeledInstruction i LTop = labeledTopInstruction i
59 labeledInstruction i (LImmediate l) = labeledImmediateInstruction i l
60 labeledInstruction i (LArtificial l) = labeledArtificialInstruction i l
61
62 labeledTopInstruction ∷ (ALU m ll element , Show element) ⇒ LabelOperation → CentralProcessingStep ll m
63 labeledTopInstruction i cpm = appendError "CPM.labeledTopInstruction" $ uncurry (labeledImmediateInstruction i) =<< cpmPop1 cpm
64
65 labeledImmediateInstruction ∷ (ALU m ll element, DynamicLabel l) ⇒ LabelOperation → l → CentralProcessingStep ll m
66 labeledImmediateInstruction i l cpm = appendError "CPM.labeledImmediateInstruction" $ flip (labeled i) cpm <$> findAddressForNaturalLabel l (cpmProgram cpm)
67
68 labeledArtificialInstruction ∷ ALU m ll element ⇒ LabelOperation → Label → CentralProcessingStep ll m
69 labeledArtificialInstruction i l cpm = appendError "CPM.labeledArtificialInstruction" $ flip (labeled i) cpm <$> findAddressForArtificialLabel l (cpmProgram cpm)
70
71 --
72
73 findAddressForNaturalLabel ∷ (MonadSafe m , DynamicLabel n) ⇒ n → InstructionVector → m InstructionAddress --FIXME
74 findAddressForNaturalLabel n il
75 | n < 0 = liftError $ show n
76 | otherwise = liftMaybeOrErrorTuple ("Undefined label", show n) $ Vector.findIndex (checkNaturalMark $ fromIntegral n) il
77
78 findAddressForArtificialLabel ∷ MonadSafe m ⇒ Label → InstructionVector → m InstructionAddress
79 findAddressForArtificialLabel l = liftMaybeOrErrorTuple ("Undefined label", show l) . Vector.findIndex (checkArtificialMark l)
80
81 --
82
83 labeled ∷ LabelOperation → InstructionCounter → CentralProcessingMemory ll → CentralProcessingMemory ll
84 labeled Jump = jump
85 labeled Call = call
86
87 jump ∷ InstructionCounter → CentralProcessingMemory ll → CentralProcessingMemory ll
88 jump a (CPM (CM il _ is) s) = CPM (CM il a is) s
89
90 call ∷ InstructionCounter → CentralProcessingMemory ll → CentralProcessingMemory ll
91 call a (CPM (CM il ic (IS is)) s) = CPM (CM il a (IS (ic : is))) s
92
93 -- | ControlMemory methods
94
95 newCM ∷ InstructionList → ControlMemory
96 newCM il = CM (Vector.fromList il) 0 (IS [])
97
98 currentInstruction ∷ MonadSafe m ⇒ ControlMemory → m Instruction
99 currentInstruction (CM il ic _) = indexSafe il ic
100
101 incrementPC ∷ ControlMemory → ControlMemory
102 incrementPC cu = cu { programCounter = 1 + programCounter cu }
103
104 cpmProgram ∷ CentralProcessingMemory al → InstructionVector
105 cpmProgram = program . controlMemory
106
107 cpmPop1 ∷ ALU m ll element ⇒ CentralProcessingMemory ll → m (element , CentralProcessingMemory ll)
108 cpmPop1 (CPM cm s) = build <$> pop1 s where
109 build (l , s') = (l , CPM cm s')
110
111 cpmPop2 ∷ ALU m ll element ⇒ CentralProcessingMemory ll → m (element , element , CentralProcessingMemory ll)
112 cpmPop2 (CPM cm s) = build <$> pop2 s where
113 build (l1 , l2 , s') = (l1 , l2 , CPM cm s')
114
115 -- | Types
116 type DynamicLabel l = (Integral l , Show l)
117
118 type CentralProcessingStep ll m = CentralProcessingMemory ll → m $ CentralProcessingMemory ll
119
120 data CentralProcessingMemory ll
121 = CPM
122 { controlMemory :: ControlMemory
123 , alm :: ll
124 }
125 deriving stock (Show)
126
127 data ControlMemory
128 = CM
129 { program :: InstructionVector
130 , programCounter :: InstructionCounter
131 , returnStack :: InstructionStack
132 }
133 deriving stock (Show)
134
135 newtype InstructionStack
136 = IS [InstructionAddress]
137 deriving stock (Show)
138
139 type InstructionCounter = InstructionAddress
140
141 type InstructionAddress = Int