From 192ce3fe3ece81ba168aff20f217b25c0b22fc72 Mon Sep 17 00:00:00 2001 From: Kristina Date: Tue, 9 Jun 2026 18:57:03 +0200 Subject: [PATCH 1/5] Init --- src/Core.hs | 342 ++++++++++++++++-------------- src/Instruction.hs | 35 +-- src/Leak/MonitorPC/MonitorLeak.hs | 2 +- src/Leak/MonitorPC/PC.hs | 10 +- src/Leak/PC/Leak.hs | 6 +- src/Leak/PC/PC.hs | 10 +- src/Leak/PC/Sim.hs | 6 +- src/Leak/SecretPC/PC.hs | 5 +- 8 files changed, 219 insertions(+), 197 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index a300ea3..06f78f8 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -2,6 +2,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} +{- HLINT ignore "Functor law" -} module Core ( initInput, @@ -107,31 +108,31 @@ instance NFDataX HaltState -- | The internal state of the CPU; essentially the pipeline registers. data State f = State - { -- | Program counter fetch stage + { -- | Program counter fetch stage. stateFePc :: Address, - -- | Program counter decode stage + -- | Program counter decode stage. stateDePc :: Address, - -- | Program counter execute stage + -- | Program counter execute stage. stateExPc :: Address, - -- | Instruction register execute stage + -- | Instruction execute stage. stateExInstr :: Instruction, - -- | Instruction register memory stage + -- | Instruction memory stage. stateMeInstr :: Instruction, - -- | ALU result register memory stage - stateMeAluRes :: f Word, - -- | Memory value to write for stores (`stateMeAluRes` only contains the address). - stateMeStoreRes :: f Word, - -- | Instruction register writeback stage + -- | Computation result memory stage. + stateMeRes :: f Word, + -- | Address for load and store, memory stage. + stateMeAddr :: Address, + -- | Instruction writeback stage. stateWbInstr :: Instruction, - -- | ALU result register writeback stage - stateWbAluRes :: f Word, - -- | Register file + -- | Computation result writeback stage. + stateWbRes :: f Word, + -- | Register file. stateRegFile :: RegFile f, -- | Control/forwarding lines. stateCtrl :: Control f, - -- | CPU halt state + -- | CPU halt state. stateHalt :: Maybe HaltState, - -- | Pending halt state (propagating through pipeline to ensure flush) + -- | Pending halt state (propagating through pipeline to ensure flush). stateHaltPending :: Maybe HaltState } @@ -148,12 +149,23 @@ data Control f = Control { -- | Stores `stateDePc` when the instruction in the `decode` stage has -- a load hazard with the instruction in the `execute` stage. ctrlDeLoadHazard :: Maybe Address, + -- | Stores `stateDePc` when the instruction in the `decode` stage has + -- a store hazard with the instruction in the `execute` stage or the + -- instruction in the `memory` stage. + ctrlDeStoreHazard :: Maybe Address, -- | Stores the instruction in the `execute` stage. ctrlExInstr :: Maybe Instruction, - -- | Stores the new PC if the instruction in the `execute` stage results in a jump. - ctrlExAddress :: Maybe Address, + -- | Stores the jump address if the instruction in the `execute` stage + -- results in a jump. + ctrlExJumpAddr :: Maybe Address, + -- | Stores the write address if the instruction in the `execute` stage + -- is a store. + ctrlExStoreAddr :: Maybe Address, -- | `True` when the instruction in the `memory` stage is a store or a load. ctrlMeMemInstr :: Bool, + -- | Stores the write address if the instruction in the `memory` stage + -- is a store. + ctrlMeStoreAddr :: Maybe Address, -- | Forwards the `rd` register from the `memory` stage to the `execute` -- stage. ctrlMeRegFwd :: Maybe (RegIdx, f Word), @@ -208,10 +220,10 @@ init = stateExPc = 0, stateExInstr = Nop FirstCycle, stateMeInstr = Nop FirstCycle, - stateMeAluRes = pure 0, - stateMeStoreRes = pure 0, + stateMeRes = pure 0, + stateMeAddr = 0, stateWbInstr = Nop FirstCycle, - stateWbAluRes = pure 0, + stateWbRes = pure 0, stateRegFile = initRF, stateCtrl = initCtrl, stateHalt = Nothing, @@ -223,9 +235,12 @@ initCtrl :: Control f initCtrl = Control { ctrlDeLoadHazard = Nothing, + ctrlDeStoreHazard = Nothing, ctrlExInstr = Nothing, - ctrlExAddress = Nothing, + ctrlExJumpAddr = Nothing, + ctrlExStoreAddr = Nothing, ctrlMeMemInstr = False, + ctrlMeStoreAddr = Nothing, ctrlMeRegFwd = Nothing, ctrlWbRegFwd = Nothing } @@ -257,178 +272,182 @@ fetch = do let next_pc = fromMaybe - ( fromMaybe - (if stall then pc else pc + 4) - $ ctrlDeLoadHazard ctrl - ) - $ ctrlExAddress ctrl + (fromMaybe + (fromMaybe + (if stall then pc else pc + 4) + (ctrlDeLoadHazard ctrl)) + (ctrlDeStoreHazard ctrl)) + (ctrlExJumpAddr ctrl) modify $ \s -> - s -- Increment program counter for next fetch. - { stateFePc = next_pc, + s { -- Increment program counter for next fetch. + stateFePc = next_pc, -- Propagate program counter to next stage. - stateDePc = if stall then stateDePc s else pc + stateDePc = pc } -- | Decode stage. decode :: (Access f) => CPUM f () decode = do input <- ask + pc <- gets stateDePc ctrl <- gets stateCtrl - + ir <- if inputIsInstr input then noSecrets' (inputMem input) (Nop Halted) (pure . decode') else pure $ Nop MemoryBusBusy - let branch_first_cycle = maybe False isNopBranchFirstCycle (ctrlExInstr ctrl) - let load_hazard_current_cycle = maybe False (loadHazard ir) (ctrlExInstr ctrl) - let load_hazard_first_cycle = maybe False isNopLoadHazardFirstCycle (ctrlExInstr ctrl) + let branch_current_cycle = isJust (ctrlExJumpAddr ctrl) + let branch_previous_cycle = maybe False isNopJumpFirstCycle (ctrlExInstr ctrl) + let call_current_cycle = maybe False isCall (ctrlExInstr ctrl) let break_current_cycle = maybe False isBreak (ctrlExInstr ctrl) let halted = maybe False isNopHalted (ctrlExInstr ctrl) + + let store_hazard_current_cycle = + (ctrlMeStoreAddr ctrl == Just pc) || + (ctrlExStoreAddr ctrl == Just pc) + + let store_hazard_previous_cycle = maybe False isNopStoreHazardFirstCycle (ctrlExInstr ctrl) + let load_hazard_current_cycle = maybe False (loadHazard ir) (ctrlExInstr ctrl) + let load_hazard_previous_cycle = maybe False isNopLoadHazardFirstCycle (ctrlExInstr ctrl) let ir' - -- If a branch was taken in this cycle, we stall. - | isJust (ctrlExAddress ctrl) = Nop BranchFirstCycle - -- If a branch was taken in the previous cycle, we stall. - | branch_first_cycle = Nop BranchSecondCycle - -- If there is a load hazard with the instruction executed in this cycle, we stall. - | load_hazard_current_cycle = Nop LoadHazardFirstCycle - -- If there was a load hazard in the previous cycle, we stall. - | load_hazard_first_cycle = Nop LoadHazardSecondCycle - -- If a syscall is executed in this cycle, we halt. + -- Stall if there is a jump in this cycle. + | branch_current_cycle = Nop JumpFirstCycle + -- Stall if there was a jump in the previous cycle. + | branch_previous_cycle = Nop JumpSecondCycle + -- Halt if a syscall is executed in this cycle. | call_current_cycle = Nop Halted - -- If a break is executed in this cycle, we halt. + -- Halt if a break is executed in this cycle. | break_current_cycle = Nop Halted - -- If the core is not running anymore, we halt. + -- Halt if the core is not running anymore. | halted = Nop Halted + -- Stall if there is a store hazard in this cycle. + | store_hazard_current_cycle = Nop StoreHazardFirstCycle + -- Stall if there was a store hazard in the previous cycle. + | store_hazard_previous_cycle = Nop StoreHazardSecondCycle + -- Stall if there is a load hazard in this cycle. + | load_hazard_current_cycle = Nop LoadHazardFirstCycle + -- Stall if there was a load hazard in the previous cycle. + | load_hazard_previous_cycle = Nop LoadHazardSecondCycle -- Otherwise we process the decoded instruction. | otherwise = ir - modify $ \s -> - s - { stateExInstr = ir', - stateExPc = stateDePc s - } + modify $ \s -> s {stateExInstr = ir', stateExPc = pc} + + when (ir' == Nop StoreHazardFirstCycle) $ do + setLines $ \c -> c {ctrlDeStoreHazard = Just pc} - when load_hazard_current_cycle $ do - pc <- gets stateDePc - setLines $ - \c -> c {ctrlDeLoadHazard = Just pc} + when (ir' == Nop LoadHazardFirstCycle) $ do + setLines $ \c -> c {ctrlDeLoadHazard = Just pc} -- | Execute stage. execute :: forall f. (Access f) => CPUM f () execute = do ir <- gets stateExInstr - modify $ \s -> s {stateMeInstr = ir, stateMeStoreRes = pure 0} - setLines $ \c -> c {ctrlExInstr = Just ir} - - -- Fetch alu operands - aluInputs <- runMaybeT $ fetchALUOperands ir + -- Default values. modify $ \s -> - let aluNOP = (ADD, pure 0, pure 0) - (op, lhs, rhs) = fromMaybe aluNOP aluInputs - res = alu op lhs rhs - in s {stateMeAluRes = res} - where - fetchALUOperands :: Instruction -> MaybeT (CPUM f) (Arith, f Word, f Word) - fetchALUOperands ir = - case ir of - Instruction.RType op _ _ _ -> do - r1 <- rs1 - r2 <- rs2 - pure (op, r1, r2) - Instruction.IType (Arith op) _ _ imm -> do - r1 <- rs1 - let imm' = signExtend imm - pure (op, r1, pure imm') - Instruction.IType (Load _ _) _ _ imm -> do - r1 <- rs1 - let imm' = signExtend imm - pure (ADD, r1, pure imm') - Instruction.SType _ imm _ _ -> do - r1 <- rs1 - r2 <- rs2 - let imm' = signExtend imm - modify $ \s -> s {stateMeStoreRes = r2} - pure (ADD, r1, pure imm') - Instruction.BType cmp imm _ _ -> do - r1 <- rs1 - r2 <- rs2 - pc <- gets $ pack . stateExPc - let doBranch = branch cmp r1 r2 - lift $ noSecrets' doBranch () $ \doBranch' -> - when doBranch' $ do - let branchAddr :: f Address - branchAddr = unpack <$> alu ADD (pure pc) (pure $ signExtend imm) - setLines $ - \c -> c {ctrlExAddress = fromPublic branchAddr} - empty - Instruction.JType _ imm -> do - pc <- gets $ pack . stateExPc - let jumpAddr :: f Address - jumpAddr = unpack <$> alu ADD (pure pc) (pure $ signExtend imm) - setLines $ - \c -> c {ctrlExAddress = fromPublic jumpAddr} - pure (ADD, pure pc, pure 4) - Instruction.IType Jump _ _ imm -> do - r1 <- rs1 - pc <- gets $ pack . stateExPc - lift $ noSecrets' r1 () $ \r1' -> do - let jumpAddr :: f Address - jumpAddr = unpack <$> alu ADD (pure r1') (pure $ signExtend imm) - setLines $ - \c -> c {ctrlExAddress = fromPublic jumpAddr} - pure (ADD, pure pc, pure 4) - Instruction.UType base _ imm -> do - base' <- case base of - Zero -> pure 0 - PC -> gets $ pack . stateExPc - let imm' = imm ++# (0 :: BitVector 12) - pure (ADD, pure base', pure imm') - Instruction.IType (Env Call) _ _ _ -> do - pc <- gets stateExPc - pendingHalt (Syscall (pc + 4)) - Instruction.IType (Env Break) _ _ _ -> do - pc <- gets stateExPc - pendingHalt (EBreak (pc + 4)) - Instruction.Nop _ -> empty - - pendingHalt :: HaltState -> MaybeT (CPUM f) a - pendingHalt hState = do - lift (modify $ \s -> s {stateHaltPending = Just hState}) >> empty + s { stateMeInstr = ir, + stateMeRes = pure 0, + stateMeAddr = 0 + } - rs1 :: MaybeT (CPUM f) (f Word) - rs1 = do - ir <- gets stateExInstr - let idx = fromMaybe 0 $ getRs1 ir + setLines $ \c -> c {ctrlExInstr = Just ir} + + case ir of + Instruction.RType op _ rs1 rs2 -> do + r1 <- getFirstArg rs1 + r2 <- getSecondArg rs2 + let res = alu op r1 r2 + modify $ \s -> s {stateMeRes = res} + Instruction.IType (Arith op) _ rs1 imm -> do + r1 <- getFirstArg rs1 + let imm' = signExtend imm + let res = alu op r1 (pure imm') + modify $ \s -> s {stateMeRes = res} + Instruction.IType (Load _ _) _ rs1 imm -> do + r1 <- getFirstArg rs1 + let imm' = signExtend imm + let res = alu ADD r1 (pure imm') + noSecrets' res () $ \res' -> do + modify $ \s -> s {stateMeAddr = unpack res'} + Instruction.SType _ imm rs1 rs2 -> do + r1 <- getFirstArg rs1 + r2 <- getSecondArg rs2 + let imm' = signExtend imm + let res = alu ADD r1 (pure imm') + modify $ \s -> s {stateMeRes = r2} + noSecrets' res () $ \res' -> do + modify $ \s -> s {stateMeAddr = unpack res'} + setLines $ \c -> c {ctrlExStoreAddr = Just $ unpack res'} + Instruction.BType cmp imm rs1 rs2 -> do + r1 <- getFirstArg rs1 + r2 <- getSecondArg rs2 + pc <- gets $ pack . stateExPc + let doBranch = branch cmp r1 r2 + noSecrets' doBranch () $ \doBranch' -> + when doBranch' $ do + let imm' = signExtend imm + let branchAddr = alu ADD (pure pc) (pure imm') :: f Word + setLines $ \c -> c {ctrlExJumpAddr = fromPublic $ unpack <$> branchAddr} + Instruction.JType _ imm -> do + pc <- gets $ pack . stateExPc + let res = alu ADD (pure pc) (pure 4) + modify $ \s -> s {stateMeRes = res} + let imm' = signExtend imm + let jumpAddr = alu ADD (pure pc) (pure imm') :: f Word + setLines $ \c -> c {ctrlExJumpAddr = fromPublic $ unpack <$> jumpAddr} + Instruction.IType Jump _ rs1 imm -> do + r1 <- getFirstArg rs1 + pc <- gets $ pack . stateExPc + let res = alu ADD (pure pc) (pure 4) + modify $ \s -> s {stateMeRes = res} + noSecrets' r1 () $ \r1' -> do + let imm' = signExtend imm + let jumpAddr = alu ADD (pure r1') (pure imm') :: f Word + setLines $ \c -> c {ctrlExJumpAddr = fromPublic $ unpack <$> jumpAddr} + Instruction.UType base _ imm -> do + base' <- + case base of + Zero -> pure 0 + PC -> gets $ pack . stateExPc + let imm' = imm ++# (0 :: BitVector 12) + let res = alu ADD (pure base') (pure imm') + modify $ \s -> s {stateMeRes = res} + Instruction.IType (Env Call) _ _ _ -> do + pc <- gets stateExPc + pendingHalt (Syscall (pc + 4)) + Instruction.IType (Env Break) _ _ _ -> do + pc <- gets stateExPc + pendingHalt (EBreak (pc + 4)) + Instruction.Nop _ -> pure () + where + getFirstArg :: RegIdx -> CPUM f (f Word) + getFirstArg idx = do rf <- gets stateRegFile - lift $ regWithFwd getRs1 (lookupRF idx rf) + regWithFwd idx (lookupRF idx rf) - rs2 :: MaybeT (CPUM f) (f Word) - rs2 = do - ir <- gets stateExInstr - let idx = fromMaybe 0 $ getRs2 ir + getSecondArg :: RegIdx -> CPUM f (f Word) + getSecondArg idx = do rf <- gets stateRegFile - lift $ regWithFwd getRs2 (lookupRF idx rf) + regWithFwd idx (lookupRF idx rf) - regWithFwd :: (Instruction -> Maybe RegIdx) -> f Word -> CPUM f (f Word) - regWithFwd getR def = do - ir <- gets stateExInstr + regWithFwd :: RegIdx -> f Word -> CPUM f (f Word) + regWithFwd idx def = do let checkForFwd line = do (fwdIdx, fwdVal) <- MaybeT $ gets $ line . stateCtrl - guard (hazardRW getR ir fwdIdx) + guard $ fwdIdx == idx && idx /= 0 pure fwdVal fmap (fromMaybe def) $ runMaybeT $ checkForFwd ctrlMeRegFwd <|> checkForFwd ctrlWbRegFwd - hazardRW :: (Instruction -> Maybe RegIdx) -> Instruction -> RegIdx -> Bool - hazardRW getR ir rd = isJust $ do - rs <- getR ir - guard $ rd /= 0 && rs == rd + pendingHalt :: HaltState -> CPUM f () + pendingHalt hState = do + modify $ \s -> s {stateHaltPending = Just hState} alu :: (Access f) => Arith -> f Word -> f Word -> f Word alu op lhs rhs = case op of @@ -461,16 +480,16 @@ branch op lhs rhs = case op of memory :: (Access f) => CPUM f () memory = do ir <- gets stateMeInstr - res <- gets stateMeAluRes - val <- gets stateMeStoreRes + res <- gets stateMeRes + addr <- gets stateMeAddr pending <- gets stateHaltPending case pending of - Just hlt -> modify $ \s -> s {stateHalt = Just hlt, stateHaltPending = Nothing} + Just hlt -> + modify $ \s -> s {stateHalt = Just hlt, stateHaltPending = Nothing} Nothing -> pure () - modify $ \s -> - s {stateWbInstr = ir, stateWbAluRes = res} + modify $ \s -> s { stateWbInstr = ir, stateWbRes = res } -- Default register forwarding. setLines $ \c -> c {ctrlMeRegFwd = Nothing} @@ -480,16 +499,12 @@ memory = do setLines $ \c -> c {ctrlMeRegFwd = Just (rd, res)} Instruction.IType (Arith _) rd _ _ -> setLines $ \c -> c {ctrlMeRegFwd = Just (rd, res)} - Instruction.IType (Load size _) _ _ _ -> - noSecrets' res () $ \res' -> do - setLines $ \c -> - c {ctrlMeMemInstr = True} - readRAM (unpack res') size - Instruction.SType size _ _ _ -> - noSecrets' res () $ \res' -> do - setLines $ \c -> - c {ctrlMeMemInstr = True} - writeRAM (unpack res') size val + Instruction.IType (Load size _) _ _ _ -> do + setLines $ \c -> c {ctrlMeMemInstr = True} + readRAM addr size + Instruction.SType size _ _ _ -> do + setLines $ \c -> c {ctrlMeMemInstr = True, ctrlMeStoreAddr = Just addr} + writeRAM addr size res Instruction.JType rd _ -> setLines $ \c -> c {ctrlMeRegFwd = Just (rd, res)} Instruction.IType Jump rd _ _ -> @@ -503,7 +518,7 @@ writeback :: forall f. (Access f) => CPUM f () writeback = do input <- asks inputMem ir <- gets stateWbInstr - res <- gets stateWbAluRes + res <- gets stateWbRes case ir of Instruction.RType _ rd _ _ -> do @@ -527,7 +542,6 @@ writeback = do writeRF rd res _ -> do setLines $ \c -> c {ctrlWbRegFwd = Nothing} - writeRF 0 (pure 0 :: f Word) where writeRF :: RegIdx -> f Word -> CPUM f () writeRF idx val = diff --git a/src/Instruction.hs b/src/Instruction.hs index 5cddcdf..ce4269e 100644 --- a/src/Instruction.hs +++ b/src/Instruction.hs @@ -20,8 +20,9 @@ module Instruction getRs2, isBreak, isCall, - isNopBranchFirstCycle, + isNopJumpFirstCycle, isNopLoadHazardFirstCycle, + isNopStoreHazardFirstCycle, isNopHalted, break, loadHazard, @@ -106,21 +107,25 @@ data IOperation -- | Reason for replacing an instruction with a nop. Some of these can be collapsed if we want to optimize later. data Reason4Stall - = -- | We took a branch 1 cycle ago. - BranchFirstCycle - | -- | We took a branch 2 cycles ago. - BranchSecondCycle - | -- | A load hazard occurred 1 cycle ago. + = -- | First instruction discarded because of a jump. + JumpFirstCycle + | -- | Second instruction discarded because of a jump. + JumpSecondCycle + | -- | First instruction discarded because of a load hazard. LoadHazardFirstCycle - | -- | A load hazard occurred 2 cycles ago. + | -- | Second instruction discarded because of a load hazard. LoadHazardSecondCycle + | -- | First instruction discarded because of a store hazard. + StoreHazardFirstCycle + | -- | Second instruction discarded because of a store hazard. + StoreHazardSecondCycle | -- | No instruction read because of memory bus overload. MemoryBusBusy - | -- | First cycle. - FirstCycle | -- | Failed to decode an instruction. DecodeFail - | -- | PC has halted. + | -- | First cycle. + FirstCycle + | -- | The core has halted. Halted deriving (Eq, Show, Generic, NFDataX, Binary) @@ -443,14 +448,18 @@ isStore :: Instruction -> Bool isStore (SType {}) = True isStore _ = False -isNopBranchFirstCycle :: Instruction -> Bool -isNopBranchFirstCycle (Nop BranchFirstCycle) = True -isNopBranchFirstCycle _ = False +isNopJumpFirstCycle :: Instruction -> Bool +isNopJumpFirstCycle (Nop JumpFirstCycle) = True +isNopJumpFirstCycle _ = False isNopLoadHazardFirstCycle :: Instruction -> Bool isNopLoadHazardFirstCycle (Nop LoadHazardFirstCycle) = True isNopLoadHazardFirstCycle _ = False +isNopStoreHazardFirstCycle :: Instruction -> Bool +isNopStoreHazardFirstCycle (Nop StoreHazardFirstCycle) = True +isNopStoreHazardFirstCycle _ = False + isNopHalted :: Instruction -> Bool isNopHalted (Nop Halted) = True isNopHalted _ = False diff --git a/src/Leak/MonitorPC/MonitorLeak.hs b/src/Leak/MonitorPC/MonitorLeak.hs index b862960..c7569ab 100644 --- a/src/Leak/MonitorPC/MonitorLeak.hs +++ b/src/Leak/MonitorPC/MonitorLeak.hs @@ -83,4 +83,4 @@ monitorJumpAddress :: LeakMonitor (Core.State Identity) (Core.Input Identity) (C monitorJumpAddress = LeakMonitor leak id where leak :: Core.State Identity -> Core.Input Identity -> (Core.State Identity, Maybe Address) - leak s i = let (s', _) = Core.circuit s i in (s', Core.ctrlExAddress $ Core.stateCtrl s') \ No newline at end of file + leak s i = let (s', _) = Core.circuit s i in (s', Core.ctrlExJumpAddr $ Core.stateCtrl s') \ No newline at end of file diff --git a/src/Leak/MonitorPC/PC.hs b/src/Leak/MonitorPC/PC.hs index 5f6468b..1b9a57f 100644 --- a/src/Leak/MonitorPC/PC.hs +++ b/src/Leak/MonitorPC/PC.hs @@ -51,13 +51,13 @@ proj s = (ts, ss) Sim.stateExPc = if halted then 0 else Core.stateExPc s, Sim.stateExInstr = if halted then Leak.nop' else Leak.toLeakInstr $ Core.stateExInstr s, Sim.stateMemInstr = if halted then Leak.nop' else killJump $ Leak.toLeakInstr $ Core.stateMeInstr s, - Sim.stateMemRes = if halted then 0 else unAccess $ Core.stateMeAluRes s, + Sim.stateMemRes = if halted then 0 else unAccess $ Core.stateMeRes s, Sim.stateWbInstr = if halted then Leak.nop' else killJump $ Leak.toLeakInstr $ Core.stateWbInstr s, - Sim.stateWbRes = if halted then 0 else unAccess $ Core.stateWbAluRes s, + Sim.stateWbRes = if halted then 0 else unAccess $ Core.stateWbRes s, Sim.stateHalt = halted, Sim.stateStallFetch = not halted && toStallFetch (Core.stateCtrl s), Sim.stateStallDecode = not halted && toStallDecode (Core.stateCtrl s), - Sim.stateJumpAddr = if halted then Nothing else Core.ctrlExAddress $ Core.stateCtrl s, + Sim.stateJumpAddr = if halted then Nothing else Core.ctrlExJumpAddr $ Core.stateCtrl s, Sim.stateFirstCycle = not halted && isNothing (Core.stateHalt s) } @@ -68,9 +68,9 @@ proj s = (ts, ss) toStallFetch :: Core.Control Identity -> Bool toStallFetch ctrl = Core.ctrlMeMemInstr ctrl - || isJust (Core.ctrlExAddress ctrl) + || isJust (Core.ctrlExJumpAddr ctrl) toStallDecode :: Core.Control Identity -> Bool toStallDecode ctrl = isJust (Core.ctrlDeLoadHazard ctrl) - || isJust (Core.ctrlExAddress ctrl) + || isJust (Core.ctrlExJumpAddr ctrl) diff --git a/src/Leak/PC/Leak.hs b/src/Leak/PC/Leak.hs index e098c42..67130c7 100644 --- a/src/Leak/PC/Leak.hs +++ b/src/Leak/PC/Leak.hs @@ -175,7 +175,7 @@ decode = do mJumpAddr <- gets stateJumpAddr firstCycle <- gets stateFirstCycle - let branch_first_cycle = Instr.isNopBranchFirstCycle exInstr + let branch_first_cycle = Instr.isNopJumpFirstCycle exInstr let load_hazard_current_cycle = Instr.loadHazard instr exInstr let load_hazard_first_cycle = Instr.isNopLoadHazardFirstCycle exInstr let call_current_cycle = Instr.isCall exInstr @@ -184,9 +184,9 @@ decode = do let ir' = -- If a branch was taken in this cycle, we stall. - if isJust mJumpAddr then Instr.Nop Instr.BranchFirstCycle + if isJust mJumpAddr then Instr.Nop Instr.JumpFirstCycle -- If a branch was taken in the previous cycle, we stall. - else if branch_first_cycle then Instr.Nop Instr.BranchSecondCycle + else if branch_first_cycle then Instr.Nop Instr.JumpSecondCycle -- If there is a load hazard with the instruction executed in this cycle, we stall. else if load_hazard_current_cycle then Instr.Nop Instr.LoadHazardFirstCycle -- If there was a load hazard in the previous cycle, we stall. diff --git a/src/Leak/PC/PC.hs b/src/Leak/PC/PC.hs index 14ca01d..4fbc4b7 100644 --- a/src/Leak/PC/PC.hs +++ b/src/Leak/PC/PC.hs @@ -82,16 +82,16 @@ proj s = (ts, ss) Leak.stateExPc = Core.stateExPc s, Leak.stateExInstr = Core.stateExInstr s, Leak.stateMemInstr = Core.stateMeInstr s, - Leak.stateMemRes = unAccess $ Core.stateMeAluRes s, - Leak.stateMemVal = unAccess $ Core.stateMeStoreRes s, + Leak.stateMemRes = unAccess $ Core.stateMeRes s, + Leak.stateMemVal = pack $ Core.stateMeAddr s, -- this is wrong, I am just making it compile Leak.stateWbInstr = Core.stateWbInstr s, - Leak.stateWbRes = unAccess $ Core.stateWbAluRes s, + Leak.stateWbRes = unAccess $ Core.stateWbRes s, Leak.stateRegFile = Core.stateRegFile s, Leak.stateMeMemInstr = Core.ctrlMeMemInstr $ Core.stateCtrl s, Leak.stateHalt = Core.stateHalt s, Leak.stateMeRegFwd = fmap (second unAccess) $ Core.ctrlMeRegFwd $ Core.stateCtrl s, Leak.stateWbRegFwd = fmap (second unAccess) $ Core.ctrlWbRegFwd $ Core.stateCtrl s, - Leak.stateJumpAddr = Core.ctrlExAddress $ Core.stateCtrl s, + Leak.stateJumpAddr = Core.ctrlExJumpAddr $ Core.stateCtrl s, Leak.stateDeLoadHazard = Core.ctrlDeLoadHazard $ Core.stateCtrl s, Leak.stateDeCall = False, Leak.stateFirstCycle = False @@ -107,7 +107,7 @@ proj s = (ts, ss) Sim.stateHalt = Core.stateHalt s, Sim.stateHaltPending = Core.stateHaltPending s, Sim.stateMeMemInstr = Core.ctrlMeMemInstr $ Core.stateCtrl s, - Sim.stateJumpAddr = Core.ctrlExAddress $ Core.stateCtrl s, + Sim.stateJumpAddr = Core.ctrlExJumpAddr $ Core.stateCtrl s, Sim.stateDeLoadHazard = Core.ctrlDeLoadHazard $ Core.stateCtrl s, Sim.stateDeCall = False, Sim.stateFirstCycle = False diff --git a/src/Leak/PC/Sim.hs b/src/Leak/PC/Sim.hs index 8635b99..1151400 100644 --- a/src/Leak/PC/Sim.hs +++ b/src/Leak/PC/Sim.hs @@ -114,9 +114,9 @@ decode = do let ir' = -- If a branch was taken in this cycle, we stall. - if isJust mJumpAddr then Leak.Instr (Leak.Nop Instr.BranchFirstCycle) (Nothing, Nothing) + if isJust mJumpAddr then Leak.Instr (Leak.Nop Instr.JumpFirstCycle) (Nothing, Nothing) -- If a branch was taken in the previous cycle, we stall. - else if branch_first_cycle then Leak.Instr (Leak.Nop Instr.BranchSecondCycle) (Nothing, Nothing) + else if branch_first_cycle then Leak.Instr (Leak.Nop Instr.JumpSecondCycle) (Nothing, Nothing) -- If there is a load hazard with the instruction executed in this cycle, we stall. else if load_hazard_current_cycle then Leak.Instr (Leak.Nop Instr.LoadHazardFirstCycle) (Nothing, Nothing) -- If there was a load hazard in the previous cycle, we stall. @@ -147,7 +147,7 @@ decode = do } where instrBase (Leak.Instr b _) = b - isNopBranchFirstCycle (Leak.Instr (Leak.Nop Instr.BranchFirstCycle) _) = True + isNopBranchFirstCycle (Leak.Instr (Leak.Nop Instr.JumpFirstCycle) _) = True isNopBranchFirstCycle _ = False isNopLoadHazardFirstCycle (Leak.Instr (Leak.Nop Instr.LoadHazardFirstCycle) _) = True isNopLoadHazardFirstCycle _ = False diff --git a/src/Leak/SecretPC/PC.hs b/src/Leak/SecretPC/PC.hs index b1d3c5d..fc68323 100644 --- a/src/Leak/SecretPC/PC.hs +++ b/src/Leak/SecretPC/PC.hs @@ -80,9 +80,8 @@ circuit (ts, ss) input = ((ts', ss'), addr) proj' :: Core.State PubSec -> SimState proj' s = s - { Core.stateMeAluRes = censor (Core.stateMeAluRes s), - Core.stateMeStoreRes = censor (Core.stateMeStoreRes s), - Core.stateWbAluRes = censor (Core.stateWbAluRes s), + { Core.stateMeRes = censor (Core.stateMeRes s), + Core.stateWbRes = censor (Core.stateWbRes s), Core.stateRegFile = let RegFile rf = Core.stateRegFile s in RegFile (Clash.Prelude.map censor rf), Core.stateCtrl = let c = Core.stateCtrl s From 502a436bb3904598965ca08f720d5aa581dab0a5 Mon Sep 17 00:00:00 2001 From: Kristina Date: Wed, 10 Jun 2026 16:13:02 +0200 Subject: [PATCH 2/5] Updated core --- src/Core.hs | 74 +++++++++++++++++++++++++++++------------------------ 1 file changed, 40 insertions(+), 34 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index 06f78f8..9087083 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -2,6 +2,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} +{-# OPTIONS_GHC -Wno-deriving-defaults #-} {- HLINT ignore "Functor law" -} module Core @@ -62,7 +63,7 @@ deriving instance (Show (f Word)) => Show (Input f) deriving instance Generic (Input f) -deriving instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Input f) +deriving anyclass instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Input f) -- | A memory access data MemAccess f = MemAccess @@ -79,7 +80,7 @@ deriving instance (Show (f Word)) => Show (MemAccess f) deriving instance Generic (MemAccess f) -deriving instance (Generic (f Word), NFDataX (f Word)) => NFDataX (MemAccess f) +deriving anyclass instance (Generic (f Word), NFDataX (f Word)) => NFDataX (MemAccess f) -- | The output of the CPU. newtype Output f = Output @@ -91,7 +92,7 @@ deriving instance (Show (f Word)) => Show (Output f) deriving instance Generic (Output f) -deriving instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Output f) +deriving anyclass instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Output f) instance Semigroup (Output f) where Output mem <> Output mem' = @@ -142,7 +143,7 @@ deriving instance (Eq (f Word)) => Eq (State f) deriving instance Generic (State f) -deriving instance (Generic (f Word), NFDataX (f Word)) => NFDataX (State f) +deriving anyclass instance (Generic (f Word), NFDataX (f Word)) => NFDataX (State f) -- | Control lines. data Control f = Control @@ -180,7 +181,7 @@ deriving instance (Eq (f Word)) => Eq (Control f) deriving instance Generic (Control f) -deriving instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Control f) +deriving anyclass instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Control f) type CPUM f = RWS (Input f) (Output f) (State f) @@ -298,40 +299,40 @@ decode = do then noSecrets' (inputMem input) (Nop Halted) (pure . decode') else pure $ Nop MemoryBusBusy - let branch_current_cycle = isJust (ctrlExJumpAddr ctrl) - let branch_previous_cycle = maybe False isNopJumpFirstCycle (ctrlExInstr ctrl) - + let halted = maybe False isNopHalted (ctrlExInstr ctrl) let call_current_cycle = maybe False isCall (ctrlExInstr ctrl) let break_current_cycle = maybe False isBreak (ctrlExInstr ctrl) - let halted = maybe False isNopHalted (ctrlExInstr ctrl) - + + let jump_current_cycle = isJust (ctrlExJumpAddr ctrl) + let jump_previous_cycle = maybe False isNopJumpFirstCycle (ctrlExInstr ctrl) + let store_hazard_current_cycle = - (ctrlMeStoreAddr ctrl == Just pc) || - (ctrlExStoreAddr ctrl == Just pc) + (ctrlExStoreAddr ctrl == Just pc) || + (ctrlMeStoreAddr ctrl == Just pc) - let store_hazard_previous_cycle = maybe False isNopStoreHazardFirstCycle (ctrlExInstr ctrl) - let load_hazard_current_cycle = maybe False (loadHazard ir) (ctrlExInstr ctrl) + let store_hazard_previous_cycle = maybe False isNopStoreHazardFirstCycle (ctrlExInstr ctrl) let load_hazard_previous_cycle = maybe False isNopLoadHazardFirstCycle (ctrlExInstr ctrl) - + let load_hazard_current_cycle = maybe False (loadHazard ir) (ctrlExInstr ctrl) + let ir' - -- Stall if there is a jump in this cycle. - | branch_current_cycle = Nop JumpFirstCycle - -- Stall if there was a jump in the previous cycle. - | branch_previous_cycle = Nop JumpSecondCycle - -- Halt if a syscall is executed in this cycle. - | call_current_cycle = Nop Halted - -- Halt if a break is executed in this cycle. - | break_current_cycle = Nop Halted -- Halt if the core is not running anymore. | halted = Nop Halted - -- Stall if there is a store hazard in this cycle. - | store_hazard_current_cycle = Nop StoreHazardFirstCycle + -- Halt if there is a syscall in this cycle. + | call_current_cycle = Nop Halted + -- Halt if there is a break in this cycle. + | break_current_cycle = Nop Halted + -- Stall if there was a jump in the previous cycle. + | jump_previous_cycle = Nop JumpSecondCycle + -- Stall if there is a jump in this cycle. + | jump_current_cycle = Nop JumpFirstCycle -- Stall if there was a store hazard in the previous cycle. | store_hazard_previous_cycle = Nop StoreHazardSecondCycle - -- Stall if there is a load hazard in this cycle. - | load_hazard_current_cycle = Nop LoadHazardFirstCycle + -- Stall if there is a store hazard in this cycle. + | store_hazard_current_cycle = Nop StoreHazardFirstCycle -- Stall if there was a load hazard in the previous cycle. | load_hazard_previous_cycle = Nop LoadHazardSecondCycle + -- Stall if there is a load hazard in this cycle. + | load_hazard_current_cycle = Nop LoadHazardFirstCycle -- Otherwise we process the decoded instruction. | otherwise = ir @@ -392,14 +393,16 @@ execute = do when doBranch' $ do let imm' = signExtend imm let branchAddr = alu ADD (pure pc) (pure imm') :: f Word - setLines $ \c -> c {ctrlExJumpAddr = fromPublic $ unpack <$> branchAddr} + setLines $ \c -> + c {ctrlExJumpAddr = fromPublic $ unpack <$> branchAddr} Instruction.JType _ imm -> do pc <- gets $ pack . stateExPc let res = alu ADD (pure pc) (pure 4) modify $ \s -> s {stateMeRes = res} let imm' = signExtend imm let jumpAddr = alu ADD (pure pc) (pure imm') :: f Word - setLines $ \c -> c {ctrlExJumpAddr = fromPublic $ unpack <$> jumpAddr} + setLines $ \c -> + c {ctrlExJumpAddr = fromPublic $ unpack <$> jumpAddr} Instruction.IType Jump _ rs1 imm -> do r1 <- getFirstArg rs1 pc <- gets $ pack . stateExPc @@ -408,7 +411,8 @@ execute = do noSecrets' r1 () $ \r1' -> do let imm' = signExtend imm let jumpAddr = alu ADD (pure r1') (pure imm') :: f Word - setLines $ \c -> c {ctrlExJumpAddr = fromPublic $ unpack <$> jumpAddr} + setLines $ \c -> + c {ctrlExJumpAddr = fromPublic $ unpack <$> jumpAddr} Instruction.UType base _ imm -> do base' <- case base of @@ -477,7 +481,7 @@ branch op lhs rhs = case op of where sign = unpack @(Signed 32) -memory :: (Access f) => CPUM f () +memory :: CPUM f () memory = do ir <- gets stateMeInstr res <- gets stateMeRes @@ -486,10 +490,11 @@ memory = do case pending of Just hlt -> - modify $ \s -> s {stateHalt = Just hlt, stateHaltPending = Nothing} + modify $ \s -> + s {stateHalt = Just hlt, stateHaltPending = Nothing} Nothing -> pure () - modify $ \s -> s { stateWbInstr = ir, stateWbRes = res } + modify $ \s -> s {stateWbInstr = ir, stateWbRes = res} -- Default register forwarding. setLines $ \c -> c {ctrlMeRegFwd = Nothing} @@ -503,7 +508,8 @@ memory = do setLines $ \c -> c {ctrlMeMemInstr = True} readRAM addr size Instruction.SType size _ _ _ -> do - setLines $ \c -> c {ctrlMeMemInstr = True, ctrlMeStoreAddr = Just addr} + setLines $ \c -> + c {ctrlMeMemInstr = True, ctrlMeStoreAddr = Just addr} writeRAM addr size res Instruction.JType rd _ -> setLines $ \c -> c {ctrlMeRegFwd = Just (rd, res)} From 0cbbcf9208070b58af6558f537639a19ce17e2ac Mon Sep 17 00:00:00 2001 From: Kristina Date: Wed, 10 Jun 2026 16:19:43 +0200 Subject: [PATCH 3/5] Updated core --- src/Core.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Core.hs b/src/Core.hs index 9087083..b3e60b5 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -481,7 +481,7 @@ branch op lhs rhs = case op of where sign = unpack @(Signed 32) -memory :: CPUM f () +memory :: (Access f) => CPUM f () memory = do ir <- gets stateMeInstr res <- gets stateMeRes From 91ff6a71d02e1ab16fb17da56dc1d221506184ad Mon Sep 17 00:00:00 2001 From: Kristina Date: Wed, 10 Jun 2026 16:22:37 +0200 Subject: [PATCH 4/5] Updating core --- src/Core.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Core.hs b/src/Core.hs index b3e60b5..8067965 100644 --- a/src/Core.hs +++ b/src/Core.hs @@ -63,7 +63,7 @@ deriving instance (Show (f Word)) => Show (Input f) deriving instance Generic (Input f) -deriving anyclass instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Input f) +deriving instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Input f) -- | A memory access data MemAccess f = MemAccess @@ -80,7 +80,7 @@ deriving instance (Show (f Word)) => Show (MemAccess f) deriving instance Generic (MemAccess f) -deriving anyclass instance (Generic (f Word), NFDataX (f Word)) => NFDataX (MemAccess f) +deriving instance (Generic (f Word), NFDataX (f Word)) => NFDataX (MemAccess f) -- | The output of the CPU. newtype Output f = Output @@ -92,7 +92,7 @@ deriving instance (Show (f Word)) => Show (Output f) deriving instance Generic (Output f) -deriving anyclass instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Output f) +deriving instance (Generic (f Word), NFDataX (f Word)) => NFDataX (Output f) instance Semigroup (Output f) where Output mem <> Output mem' = From 9ed0a069073df434a23471e8953de241707757fb Mon Sep 17 00:00:00 2001 From: Kristina Date: Wed, 10 Jun 2026 16:41:16 +0200 Subject: [PATCH 5/5] Attempt to fix the compile error --- test/Spec.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/test/Spec.hs b/test/Spec.hs index 999d14a..d7a2887 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -289,6 +289,9 @@ instance {-# OVERLAPPING #-} (Access f) => Arbitrary (Control f) where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary <*> genMaybeRegFwd <*> genMaybeRegFwd where