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