never executed always true always false

    1 module HelVM.HelMA.Automaton.Combiner.LSU where
    2 
    3 import           HelVM.HelMA.Automaton.Combiner.ALU
    4 import qualified HelVM.HelMA.Automaton.Combiner.RAM                     as RAM
    5 
    6 import           HelVM.HelMA.Automaton.Eff.MonadEff
    7 
    8 import           HelVM.HelMA.Automaton.Instruction.Extras.Common
    9 import           HelVM.HelMA.Automaton.Instruction.Groups.IOInstruction
   10 import           HelVM.HelMA.Automaton.Instruction.Groups.LSInstruction
   11 
   12 import           HelVM.HelIO.Control.Safe
   13 
   14 import           Control.Type.Operator
   15 
   16 runSLI ∷ (LSU m s r element) ⇒ LSInstruction → LoadStoreMemory s r → m $ LoadStoreMemory s r
   17 runSLI Load             = load
   18 runSLI Store            = store
   19 runSLI (LoadD     a)    = loadD a
   20 runSLI (StoreID v a)    = storeID v a
   21 runSLI (MoveD   s d)    = moveD s d
   22 runSLI (MIO OutputChar) = loadOutputChar
   23 runSLI (MIO OutputDec)  = loadOutputDec
   24 runSLI (MIO InputChar)  = storeInputChar
   25 runSLI (MIO InputDec)   = storeInputDec
   26 
   27 load ∷ LSU m s r element ⇒ LoadStoreMemory s r → m $ LoadStoreMemory s r
   28 load (LSM s r) = appendError "LSM.load" $ build =<< pop1 s where
   29   build (address , s') = loadPure address $ LSM s' r
   30 
   31 loadD ∷ LSU m s r element ⇒ ImmediateIndex → LoadStoreMemory s r → m $ LoadStoreMemory s r
   32 loadD address = loadPure (fromIntegral address)
   33 
   34 loadPure ∷ LSU m s r element ⇒ element → LoadStoreMemory s r → m $ LoadStoreMemory s r
   35 loadPure address (LSM s r) = pure $ LSM (push1 (RAM.genericLoad r address) s) r
   36 
   37 store ∷ LSU m s r element ⇒ LoadStoreMemory s r → m $ LoadStoreMemory s r
   38 store (LSM s r) = appendError "LSM.store" $ build =<< pop2 s where
   39   build (value , address , s') = storePure value address $ LSM s' r
   40 
   41 storeID ∷ LSU m s r element ⇒ Integer → ImmediateIndex → LoadStoreMemory s r → m $ LoadStoreMemory s r
   42 storeID value address = storePure (fromIntegral value) (fromIntegral address)
   43 
   44 storePure ∷ LSU m s r element ⇒ element → element → LoadStoreMemory s r → m $ LoadStoreMemory s r
   45 storePure value address (LSM s r) = pure $ LSM s $ RAM.store address value r
   46 
   47 moveD ∷ LSU m s r element ⇒ ImmediateIndex → ImmediateIndex → LoadStoreMemory s r → m $ LoadStoreMemory s r
   48 moveD src dst lsm@(LSM _ r) = storePure (RAM.genericLoad r src) (fromIntegral dst) lsm
   49 
   50 -- | IO
   51 
   52 loadOutputChar ∷ LSU m s r element ⇒ LoadStoreMemory s r → m $ LoadStoreMemory s r
   53 loadOutputChar (LSM s r) = appendError "LSM.loadOutputChar" $ build =<< pop1 s where
   54   build (address , s') = LSM s' r <$ putAsChar (RAM.genericLoad r address)
   55 
   56 loadOutputDec ∷ LSU m s r element ⇒ LoadStoreMemory s r → m $ LoadStoreMemory s r
   57 loadOutputDec (LSM s r) = appendError "LSM.loadOutputDec" $ build =<< pop1 s where
   58   build (address , s') = LSM s' r <$ putAsDec (RAM.genericLoad r address)
   59 
   60 storeInputChar ∷ LSU m s r element ⇒ LoadStoreMemory s r → m $ LoadStoreMemory s r
   61 storeInputChar (LSM s r) = appendError "LSM.storeInputChar" $ build =<< pop1 s where
   62   build (address , s') = LSM s' . flip (RAM.store address) r <$> getCharAs
   63 
   64 storeInputDec ∷ LSU m s r element ⇒ LoadStoreMemory s r → m $ LoadStoreMemory s r
   65 storeInputDec (LSM s r) = appendError "LSM.storeInputDec" $ build =<< pop1 s where
   66   build (address , s') = LSM s' . flip (RAM.store address) r <$> getDecAs
   67 
   68 -- | Types
   69 type LSU m s r element = (ALU m s element , RAM.RAM r element)
   70 
   71 data LoadStoreMemory s r
   72   = LSM
   73       { stack :: s
   74       , ram   :: r
   75       }