From d696a98e70e72fdfbaad7d0c14794247cede6a3d Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Thu, 5 Dec 2024 12:40:53 +0100 Subject: [PATCH] comments in CASM output --- src/Juvix/Compiler/Casm/Extra/Base.hs | 30 ++++++++++++------- src/Juvix/Compiler/Casm/Language.hs | 15 ++++++---- src/Juvix/Compiler/Casm/Pretty/Base.hs | 20 +++++++++---- .../Casm/Transformation/Optimize/Peephole.hs | 3 +- .../Compiler/Casm/Translation/FromCairo.hs | 12 +++++--- .../Compiler/Casm/Translation/FromReg.hs | 30 ++++++++++++++----- .../Compiler/Casm/Translation/FromSource.hs | 20 +++++++++---- src/Juvix/Compiler/Reg/Pretty.hs | 6 ++-- 8 files changed, 95 insertions(+), 41 deletions(-) diff --git a/src/Juvix/Compiler/Casm/Extra/Base.hs b/src/Juvix/Compiler/Casm/Extra/Base.hs index bc55de032b..b1904288ff 100644 --- a/src/Juvix/Compiler/Casm/Extra/Base.hs +++ b/src/Juvix/Compiler/Casm/Extra/Base.hs @@ -14,35 +14,43 @@ adjustAp idx mr@MemRef {..} = case _memRefReg of Ap -> MemRef Ap (_memRefOff - idx) Fp -> mr -mkAssign :: MemRef -> RValue -> Instruction -mkAssign mr rv = +mkAssign' :: Maybe Text -> MemRef -> RValue -> Instruction +mkAssign' comment mr rv = Assign InstrAssign { _instrAssignResult = mr, _instrAssignValue = rv, - _instrAssignIncAp = False + _instrAssignIncAp = False, + _instrAssignComment = comment } -mkAssignAp :: RValue -> Instruction -mkAssignAp v = +mkAssign :: MemRef -> RValue -> Instruction +mkAssign = mkAssign' Nothing + +mkAssignAp' :: Maybe Text -> RValue -> Instruction +mkAssignAp' comment v = Assign InstrAssign { _instrAssignResult = MemRef Ap 0, _instrAssignValue = v, - _instrAssignIncAp = True + _instrAssignIncAp = True, + _instrAssignComment = comment } +mkAssignAp :: RValue -> Instruction +mkAssignAp = mkAssignAp' Nothing + mkCallRel :: Value -> Instruction -mkCallRel tgt = Call (InstrCall tgt True) +mkCallRel tgt = Call (InstrCall tgt True Nothing) mkCallAbs :: Value -> Instruction -mkCallAbs tgt = Call (InstrCall tgt False) +mkCallAbs tgt = Call (InstrCall tgt False Nothing) mkJumpAbs :: RValue -> Instruction -mkJumpAbs tgt = Jump (InstrJump tgt False False) +mkJumpAbs tgt = Jump (InstrJump tgt False False Nothing) mkJumpIf :: Value -> MemRef -> Instruction -mkJumpIf tgt v = JumpIf (InstrJumpIf tgt v False) +mkJumpIf tgt v = JumpIf (InstrJumpIf tgt v False Nothing) mkJumpRel :: RValue -> Instruction -mkJumpRel tgt = Jump (InstrJump tgt True False) +mkJumpRel tgt = Jump (InstrJump tgt True False Nothing) diff --git a/src/Juvix/Compiler/Casm/Language.hs b/src/Juvix/Compiler/Casm/Language.hs index 6528927cc7..ad30552d27 100644 --- a/src/Juvix/Compiler/Casm/Language.hs +++ b/src/Juvix/Compiler/Casm/Language.hs @@ -99,7 +99,8 @@ data Instruction data InstrAssign = InstrAssign { _instrAssignValue :: RValue, _instrAssignResult :: MemRef, - _instrAssignIncAp :: Bool + _instrAssignIncAp :: Bool, + _instrAssignComment :: Maybe Text } data InstrExtraBinop = InstrExtraBinop @@ -107,13 +108,15 @@ data InstrExtraBinop = InstrExtraBinop _instrExtraBinopArg2 :: Value, _instrExtraBinopResult :: MemRef, _instrExtraBinopOpcode :: ExtraOpcode, - _instrExtraBinopIncAp :: Bool + _instrExtraBinopIncAp :: Bool, + _instrExtraBinopComment :: Maybe Text } data InstrJump = InstrJump { _instrJumpTarget :: RValue, _instrJumpRel :: Bool, - _instrJumpIncAp :: Bool + _instrJumpIncAp :: Bool, + _instrJumpComment :: Maybe Text } -- | Jump if value is nonzero. Boolean true is translated to zero, false to @@ -121,12 +124,14 @@ data InstrJump = InstrJump data InstrJumpIf = InstrJumpIf { _instrJumpIfTarget :: Value, _instrJumpIfValue :: MemRef, - _instrJumpIfIncAp :: Bool + _instrJumpIfIncAp :: Bool, + _instrJumpIfComment :: Maybe Text } data InstrCall = InstrCall { _instrCallTarget :: Value, - _instrCallRel :: Bool + _instrCallRel :: Bool, + _instrCallComment :: Maybe Text } newtype InstrAlloc = InstrAlloc diff --git a/src/Juvix/Compiler/Casm/Pretty/Base.hs b/src/Juvix/Compiler/Casm/Pretty/Base.hs index 1645b7c95d..80096974ec 100644 --- a/src/Juvix/Compiler/Casm/Pretty/Base.hs +++ b/src/Juvix/Compiler/Casm/Pretty/Base.hs @@ -23,6 +23,11 @@ ppIncAp = \case True -> return $ Str.semicolon <+> Str.apPlusPlus False -> mempty +ppComment :: Maybe Text -> Sem r (Doc Ann) +ppComment = \case + Just c -> return $ Str.commentLineStart <+> pretty c <> hardline + Nothing -> return mempty + instance PrettyCode Reg where ppCode = \case Ap -> return Str.ap @@ -121,19 +126,21 @@ instance PrettyCode Hint where instance PrettyCode InstrAssign where ppCode InstrAssign {..} = do + comment <- ppComment _instrAssignComment v <- ppCode _instrAssignValue r <- ppCode _instrAssignResult incAp <- ppIncAp _instrAssignIncAp - return $ r <+> Str.equal <+> v <> incAp + return $ comment <> r <+> Str.equal <+> v <> incAp instance PrettyCode InstrExtraBinop where ppCode InstrExtraBinop {..} = do + comment <- ppComment _instrExtraBinopComment v1 <- ppCode _instrExtraBinopArg1 v2 <- ppCode _instrExtraBinopArg2 op <- ppCode _instrExtraBinopOpcode r <- ppCode _instrExtraBinopResult incAp <- ppIncAp _instrExtraBinopIncAp - return $ r <+> Str.equal <+> v1 <+> op <+> v2 <> incAp + return $ comment <> r <+> Str.equal <+> v1 <+> op <+> v2 <> incAp ppRel :: Bool -> RValue -> Sem r (Doc Ann) ppRel isRel tgt @@ -148,23 +155,26 @@ ppRel isRel tgt instance PrettyCode InstrJump where ppCode InstrJump {..} = do + comment <- ppComment _instrJumpComment tgt <- ppCode _instrJumpTarget incAp <- ppIncAp _instrJumpIncAp rel <- ppRel _instrJumpRel _instrJumpTarget - return $ Str.jmp <+> rel <> tgt <> incAp + return $ comment <> Str.jmp <+> rel <> tgt <> incAp instance PrettyCode InstrJumpIf where ppCode InstrJumpIf {..} = do + comment <- ppComment _instrJumpIfComment tgt <- ppCode _instrJumpIfTarget v <- ppCode _instrJumpIfValue incAp <- ppIncAp _instrJumpIfIncAp - return $ Str.jmp <+> tgt <+> Str.if_ <+> v <+> Str.notequal <+> annotate AnnLiteralInteger "0" <> incAp + return $ comment <> Str.jmp <+> tgt <+> Str.if_ <+> v <+> Str.notequal <+> annotate AnnLiteralInteger "0" <> incAp instance PrettyCode InstrCall where ppCode InstrCall {..} = do + comment <- ppComment _instrCallComment tgt <- ppCode _instrCallTarget rel <- ppRel _instrCallRel (Val _instrCallTarget) - return $ Str.call <+> rel <> tgt + return $ comment <> Str.call <+> rel <> tgt instance PrettyCode InstrAlloc where ppCode InstrAlloc {..} = do diff --git a/src/Juvix/Compiler/Casm/Transformation/Optimize/Peephole.hs b/src/Juvix/Compiler/Casm/Transformation/Optimize/Peephole.hs index d934de5710..db5953d6e1 100644 --- a/src/Juvix/Compiler/Casm/Transformation/Optimize/Peephole.hs +++ b/src/Juvix/Compiler/Casm/Transformation/Optimize/Peephole.hs @@ -41,7 +41,8 @@ peephole = mapT go let call = InstrCall { _instrCallTarget = tgt, - _instrCallRel = _instrJumpRel + _instrCallRel = _instrJumpRel, + _instrCallComment } in Call call : Return : is is -> is diff --git a/src/Juvix/Compiler/Casm/Translation/FromCairo.hs b/src/Juvix/Compiler/Casm/Translation/FromCairo.hs index 6b9fccee10..5dba9f0a4b 100644 --- a/src/Juvix/Compiler/Casm/Translation/FromCairo.hs +++ b/src/Juvix/Compiler/Casm/Translation/FromCairo.hs @@ -75,7 +75,8 @@ fromCairo elems0 = Call InstrCall { _instrCallRel = _instrPcUpdate == Cairo.PcUpdateJumpRel, - _instrCallTarget = val + _instrCallTarget = val, + _instrCallComment = Nothing } (rval, delta) = decodeRes i elems val = case rval of @@ -110,7 +111,8 @@ fromCairo elems0 = InstrAssign { _instrAssignResult = dst, _instrAssignValue = rval, - _instrAssignIncAp = _instrApUpdate == Cairo.ApUpdateInc + _instrAssignIncAp = _instrApUpdate == Cairo.ApUpdateInc, + _instrAssignComment = Nothing } goNop :: Cairo.Instruction -> [Cairo.Element] -> (Instruction, Int) @@ -136,7 +138,8 @@ fromCairo elems0 = InstrJump { _instrJumpTarget = res, _instrJumpRel = isRel, - _instrJumpIncAp = _instrApUpdate == Cairo.ApUpdateInc + _instrJumpIncAp = _instrApUpdate == Cairo.ApUpdateInc, + _instrJumpComment = Nothing } goJumpIf :: Cairo.Instruction -> [Cairo.Element] -> (Instruction, Int) @@ -159,7 +162,8 @@ fromCairo elems0 = InstrJumpIf { _instrJumpIfTarget = tgt, _instrJumpIfValue = dst, - _instrJumpIfIncAp = _instrApUpdate == Cairo.ApUpdateInc + _instrJumpIfIncAp = _instrApUpdate == Cairo.ApUpdateInc, + _instrJumpIfComment = Nothing } goAlloc :: Cairo.Instruction -> [Cairo.Element] -> (Instruction, Int) diff --git a/src/Juvix/Compiler/Casm/Translation/FromReg.hs b/src/Juvix/Compiler/Casm/Translation/FromReg.hs index 6cd31cb04d..2ea500f89f 100644 --- a/src/Juvix/Compiler/Casm/Translation/FromReg.hs +++ b/src/Juvix/Compiler/Casm/Translation/FromReg.hs @@ -14,6 +14,7 @@ import Juvix.Compiler.Casm.Translation.FromReg.CasmBuilder import Juvix.Compiler.Reg.Data.Blocks.InfoTable qualified as Reg import Juvix.Compiler.Reg.Extra.Blocks.Info qualified as Reg import Juvix.Compiler.Reg.Language.Blocks qualified as Reg +import Juvix.Compiler.Reg.Pretty qualified as Reg import Juvix.Compiler.Tree.Evaluator.Builtins qualified as Reg import Juvix.Compiler.Tree.Extra.Rep qualified as Reg import Juvix.Data.Field @@ -141,6 +142,9 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI argsOffset :: Int argsOffset = 3 + ppVarComment :: Reg.VarRef -> Int -> Text + ppVarComment var off = Reg.ppPrint tab var <> " is [fp + " <> show off <> "]" + goFun :: forall r. (Member LabelInfoBuilder r) => StdlibBuiltins -> LabelRef -> (Address, [[Instruction]]) -> Reg.FunctionInfo -> Sem r (Address, [[Instruction]]) goFun blts failLab (addr0, acc) funInfo = do let sym = funInfo ^. Reg.functionSymbol @@ -218,7 +222,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI ++ zipWithExact (\var k -> (var, -argsOffset - k)) liveVars' [0 .. n - 1] unless updatedBuiltins $ goAssignApBuiltins - mapM_ (mkMemRef >=> goAssignAp . Val . Ref) (reverse liveVars') + mapM_ saveLiveVar (reverse liveVars') output'' (mkCallRel $ Imm 3) output'' Return -- we need the Nop instruction to ensure that the relative call offset @@ -228,6 +232,12 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI setAP 0 setVars vars setBuiltinOffset bltOff + where + saveLiveVar :: Reg.VarRef -> Sem r () + saveLiveVar var = do + ref <- mkMemRef var + let comment = Reg.ppPrint tab var + goAssignAp' (Just comment) (Val (Ref ref)) goLocalBlock :: Int -> HashMap Reg.VarRef Int -> Int -> HashSet Reg.VarRef -> Maybe Reg.VarRef -> Reg.Block -> Sem r () goLocalBlock ap0 vars bltOff liveVars mout' block = do @@ -295,11 +305,15 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI goAssignVar vr val = do off <- getAP insertVar vr off - goAssignAp val + let comment = ppVarComment vr off + goAssignAp' (Just comment) val + + goAssignAp' :: Maybe Text -> RValue -> Sem r () + goAssignAp' comment val = do + output' 1 (mkAssignAp' comment val) goAssignAp :: RValue -> Sem r () - goAssignAp val = do - output' 1 (mkAssignAp val) + goAssignAp = goAssignAp' Nothing goAssignValue :: Reg.VarRef -> Reg.Value -> Sem r () goAssignValue vr v = mkRValue v >>= goAssignVar vr @@ -308,7 +322,7 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI goAssignApValue v = mkRValue v >>= goAssignAp goAssignApBuiltins :: Sem r () - goAssignApBuiltins = mkBuiltinRef >>= goAssignAp . Val . Ref + goAssignApBuiltins = mkBuiltinRef >>= goAssignAp' (Just "builtins pointer") . Val . Ref -- Warning: the result may depend on Ap. Use adjustAp when changing Ap -- afterwards. @@ -334,7 +348,8 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI _instrExtraBinopResult = MemRef Ap 0, _instrExtraBinopArg1 = arg1, _instrExtraBinopArg2 = arg2, - _instrExtraBinopIncAp = True + _instrExtraBinopIncAp = True, + _instrExtraBinopComment = Just (ppVarComment res off) } goNativeBinop :: Opcode -> Reg.VarRef -> MemRef -> Value -> Sem r () @@ -370,7 +385,8 @@ fromReg tab = mkResult $ run $ runLabelInfoBuilderWithNextId (Reg.getNextSymbolI _binopValueArg2 = Imm 1, _binopValueOpcode = FieldAdd }, - _instrAssignIncAp = True + _instrAssignIncAp = True, + _instrAssignComment = Nothing } Lab {} -> impossible diff --git a/src/Juvix/Compiler/Casm/Translation/FromSource.hs b/src/Juvix/Compiler/Casm/Translation/FromSource.hs index 9568237d99..ae3b35a0e6 100644 --- a/src/Juvix/Compiler/Casm/Translation/FromSource.hs +++ b/src/Juvix/Compiler/Casm/Translation/FromSource.hs @@ -222,7 +222,8 @@ parseJump = do InstrJumpIf { _instrJumpIfTarget = tgt, _instrJumpIfValue = v, - _instrJumpIfIncAp = incAp + _instrJumpIfIncAp = incAp, + _instrJumpIfComment = Nothing } jmp :: ParsecS r Instruction @@ -235,7 +236,8 @@ parseJump = do InstrJump { _instrJumpTarget = tgt, _instrJumpRel = isRel, - _instrJumpIncAp = incAp + _instrJumpIncAp = incAp, + _instrJumpComment = Nothing } parseCall :: (Member LabelInfoBuilder r) => ParsecS r Instruction @@ -243,7 +245,13 @@ parseCall = do kw kwCall isRel <- parseRel v <- parseValue - return $ Call $ InstrCall {_instrCallTarget = v, _instrCallRel = isRel} + return $ + Call $ + InstrCall + { _instrCallTarget = v, + _instrCallRel = isRel, + _instrCallComment = Nothing + } parseReturn :: ParsecS r Instruction parseReturn = do @@ -277,7 +285,8 @@ parseAssign = do InstrAssign { _instrAssignValue = v, _instrAssignResult = res, - _instrAssignIncAp = incAp + _instrAssignIncAp = incAp, + _instrAssignComment = Nothing } extraBinop :: MemRef -> ParsecS r Instruction @@ -293,7 +302,8 @@ parseAssign = do _instrExtraBinopArg2 = arg2, _instrExtraBinopOpcode = op, _instrExtraBinopResult = res, - _instrExtraBinopIncAp = incAp + _instrExtraBinopIncAp = incAp, + _instrExtraBinopComment = Nothing } parseExtraValue :: ExtraOpcode -> ParsecS r Value diff --git a/src/Juvix/Compiler/Reg/Pretty.hs b/src/Juvix/Compiler/Reg/Pretty.hs index 47fe4d9e98..625c090c59 100644 --- a/src/Juvix/Compiler/Reg/Pretty.hs +++ b/src/Juvix/Compiler/Reg/Pretty.hs @@ -12,7 +12,7 @@ import Juvix.Data.PPOutput import Juvix.Prelude import Prettyprinter.Render.Terminal qualified as Ansi -ppOutDefault :: (PrettyCode c) => InfoTable -> c -> AnsiText +ppOutDefault :: (PrettyCode c) => InfoTable' t e -> c -> AnsiText ppOutDefault tab = mkAnsiText . PPOutput . doc (defaultOptions tab) ppOut :: (PrettyCode c) => Options -> c -> AnsiText @@ -21,8 +21,8 @@ ppOut o = mkAnsiText . PPOutput . doc o ppTrace' :: (PrettyCode c) => Options -> c -> Text ppTrace' opts = Ansi.renderStrict . reAnnotateS stylize . layoutPretty defaultLayoutOptions . doc opts -ppTrace :: (PrettyCode c) => InfoTable -> c -> Text +ppTrace :: (PrettyCode c) => InfoTable' t e -> c -> Text ppTrace tab = ppTrace' (defaultOptions tab) -ppPrint :: (PrettyCode c) => InfoTable -> c -> Text +ppPrint :: (PrettyCode c) => InfoTable' t e -> c -> Text ppPrint tab = toPlainText . ppOutDefault tab