never executed always true always false
1 module HelVM.HelMA.Automaton.Combiner.ALU
2 ( ALU
3 , SafeStack
4 , Stack
5 , binaryInstruction
6 , binaryInstructions
7 , charPush1
8 , copy
9 , discard
10 , divMod
11 , drop
12 , flipPush1
13 , genericPush1
14 , halibut
15 , inputChar
16 , inputDec
17 , lNot
18 , move
19 , outputChar
20 , outputCharMaybe
21 , outputDec
22 , outputDecMaybe
23 , pop1
24 , pop2
25 , push1
26 , push2
27 , roll
28 , rollImediate
29 , runALI
30 , runSAL
31 , slide
32 , splitAt
33 , sub
34 ) where
35
36 import HelVM.HelMA.Automaton.Instruction.Extras.Common
37
38 import HelVM.HelMA.Automaton.Instruction.Groups.IOInstruction
39 import HelVM.HelMA.Automaton.Instruction.Groups.SMInstruction
40
41 import HelVM.HelMA.Automaton.Eff.MonadEff
42
43 import HelVM.HelIO.Control.Safe
44
45 import HelVM.HelIO.Containers.MTIndexSafe
46 import HelVM.HelIO.SequencesExtra
47
48 import Control.Applicative.Tools
49 import Data.MonoTraversable
50 import Data.Sequences
51 import Prelude hiding ( divMod, drop, fromList, length, splitAt, swap, uncons )
52
53
54 runALI ∷ ALU m ll element ⇒ SMInstruction → ll → m ll
55 runALI (SPure ali) = runSAL ali
56 runALI (SIO ioi) = runSIO ioi
57
58 runSIO ∷ ALU m ll element ⇒ IOInstruction → ll → m ll
59 runSIO OutputChar = outputChar
60 runSIO OutputDec = outputDec
61 runSIO InputChar = inputChar
62 runSIO InputDec = inputDec
63
64 runSAL ∷ SafeStack m ll element ⇒ SPureInstruction → ll → m ll
65 runSAL (Cons i ) = push i
66 runSAL (Unary op ) = unaryInstruction op
67 runSAL (Binary op ) = binaryInstruction op
68 runSAL (Binaries ops ) = binaryInstructions ops
69 runSAL (Indexed t op) = indexedInstruction op t
70 runSAL Halibut = halibut
71 runSAL Pick = pick
72 runSAL Discard = discard
73
74 -- | Arithmetic instructions
75 unaryInstruction ∷ SafeStack m ll element ⇒ UnaryOperation → ll → m ll
76 unaryInstruction (UImmediate i op) = build <.> pop1 where
77 build (e , l) = push1 (calculateOp (fromInteger i) e op) l
78 unaryInstruction LNot = lNot
79 unaryInstruction op = error $ show op
80
81 lNot ∷ SafeStack m ll element ⇒ ll → m ll
82 lNot = build <.> pop1 where
83 build (e , l) = push1 (go e) l
84 go 0 = 1
85 go _ = 0
86
87 divMod ∷ SafeStack m ll element ⇒ ll → m ll
88 divMod = appendError "ALU.divMod" . binaryInstructions [Mod , Div]
89
90 sub ∷ SafeStack m ll element ⇒ ll → m ll
91 sub = appendError "ALU.sub" . binaryInstruction Sub
92
93 binaryInstruction ∷ SafeStack m ll element ⇒ BinaryOperation → ll → m ll
94 binaryInstruction i = binaryInstructions [i]
95
96 binaryInstructions ∷ SafeStack m ll element ⇒ [BinaryOperation] → ll → m ll
97 binaryInstructions il = build <.> pop2 where
98 build (e , e', l) = pushList (calculateOps e e' il) l
99
100 -- | IO instructions
101 outputCharMaybe ∷ ALU m ll element ⇒ ll → m ll
102 outputCharMaybe = appendError "ALU.outputCharMaybe" . outputMaybe putAsChar
103
104 outputDecMaybe ∷ ALU m ll element ⇒ ll → m ll
105 outputDecMaybe = appendError "ALU.outputDecMaybe" .outputMaybe putAsDec
106
107 outputMaybe ∷ ALU m ll element ⇒ (element → m ()) → ll → m ll
108 outputMaybe putAs l = maybe (pure l) f (uncons l) where f = uncurry $ flip (<$) . putAs
109
110 outputChar ∷ ALU m ll element ⇒ ll → m ll
111 outputChar = appendError "ALU.outputChar" . build <=< pop1 where
112 build (e , l) = putAsChar e $> l
113
114 outputDec ∷ ALU m ll element ⇒ ll → m ll
115 outputDec = appendError "ALU.outputDec" . build <=< pop1 where
116 build (e , l) = putAsDec e $> l
117
118 inputChar ∷ ALU m ll element ⇒ ll → m ll
119 inputChar l = appendError "ALU.inputChar" $ build <$> getCharAs where
120 build e = push1 e l
121
122 inputDec ∷ ALU m ll element ⇒ ll → m ll
123 inputDec l = appendError "ALU.inputDec" $ build <$> getDecAs where
124 build e = push1 e l
125
126 indexedInstruction ∷ SafeStack m ll element ⇒ IndexedOperation → IndexOperand → ll → m ll
127 indexedInstruction i ITop = indexedInstructionTop i
128 indexedInstruction i (IImmediate n) = indexedInstructionImmediate i n
129
130 -- | Indexed instructions
131 indexedInstructionTop ∷ SafeStack m ll element ⇒ IndexedOperation → ll → m ll
132 indexedInstructionTop op = appendError "ALU.indexedInstructionTop" . build <=< unconsSafe where
133 build (e , l) = indexedInstructionImmediate op (fromIntegral e) l
134
135 indexedInstructionImmediate ∷ SafeStack m ll element ⇒ IndexedOperation → ImmediateIndex → ll → m ll
136 indexedInstructionImmediate Copy = copy
137 indexedInstructionImmediate Move = move
138 indexedInstructionImmediate Slide = slide
139
140 -- | Halibut and Pick instructions
141
142 roll ∷ SafeStack m ll element ⇒ ll → m ll
143 roll = appendError "ALU.roll" . build <=< pop2 where
144 build (rolls, depth, l) = rollImediate (fromIntegral rolls) (fromIntegral depth) l
145
146 halibut ∷ SafeStack m ll element ⇒ ll → m ll
147 halibut = appendError "ALU.halibut" . build <=< pop1 where
148 build (e , l)
149 | 0 < i = move i l
150 | otherwise = copy (negate i) l
151 where i = fromIntegral e
152
153 pick ∷ SafeStack m ll element ⇒ ll → m ll
154 pick = appendError "ALU.pick" . build <=< pop1 where
155 build (e , l)
156 | 0 <= i = copy i l
157 | otherwise = move (negate i) l
158 where i = fromIntegral e
159
160 -- | Slide instructions
161 slide ∷ SafeStack m ll element ⇒ ImmediateIndex → ll → m ll
162 slide i = appendError "ALU.slide" . build <.> pop1 where
163 build (e , l) = push1 e $ drop i l
164
165 move ∷ SafeStack m ll element ⇒ ImmediateIndex → ll → m ll
166 move i = appendError "ALU.move" . rollImediate i (i + 1)
167
168 rollImediate ∷ SafeStack m ll element ⇒ ImmediateIndex → ImmediateIndex → ll → m ll
169 rollImediate rolls i l = appendError "ALU.rollImediate" . build $ olength l where
170 build ll
171 | i < 0 = pure l
172 | r == 0 = pure l
173 | ll < i = liftErrorWithTupleList "ALU.role index must be less then length" [("i" , show i) , ("ll" , show ll)]
174 | otherwise = pure $ l1 <> l2 <> l3
175 where
176 r = rolls `mod` i
177 (l2, l1) = splitAt r l'
178 (l', l3) = splitAt i l
179
180 -- | Copy instructions
181 copy ∷ SafeStack m ll element ⇒ ImmediateIndex → ll → m ll
182 copy i = appendError "ALU.copy" . teeMap flipPush1 (findSafe i)
183
184 -- | Pop instructions
185 pop1 ∷ SafeStack m ll element ⇒ ll → m (element , ll)
186 pop1 = appendError "ALU.pop1" . unconsSafe
187
188 pop2 ∷ SafeStack m ll element ⇒ ll → m (element , element , ll)
189 pop2 = appendError "ALU.pop2" . uncons2Safe
190
191 -- | Push instructions
192 push ∷ SafeStack m ll element ⇒ Integer → ll → m ll
193 push i = pure . genericPush1 i
194
195 flipPush1 ∷ Stack ll element ⇒ ll → element → ll
196 flipPush1 = flip push1
197
198 charPush1 ∷ (Num element , Stack ll element) ⇒ Char → ll → ll
199 charPush1 = genericPush1 . ord
200
201 genericPush1 ∷ (Integral v , Num element , Stack ll element) ⇒ v → ll → ll
202 genericPush1 = push1 . fromIntegral
203
204 push1 ∷ Stack ll element ⇒ element → ll → ll
205 push1 e = pushList [e]
206
207 push2 ∷ Stack ll element ⇒ element → element → ll → ll
208 push2 e e' = pushList [e , e']
209
210 pushList ∷ Stack ll element ⇒ [element] → ll → ll
211 pushList es l = fromList es <> l
212
213 teeMap ∷ Functor f ⇒ (t → a → b) → (t → f a) → t → f b
214 teeMap f2 f1 x = f2 x <$> f1 x
215
216 -- | Types
217 type ALU m ll element = (AppSafeEff m , SafeStack m ll element)
218
219 type SafeStack m ll element = (MonadSafe m , IntegralStack ll element)
220
221 type IntegralStack ll element = (Stack ll element , Integral element)
222
223 type Stack ll element = (Element ll ~ element , Index ll ~ Int , LL ll)
224
225 type LL ll = (Show ll , IsSequence ll , IndexSafe ll)