From ef438c3a570032553c78a00d791f5ebffef328fb Mon Sep 17 00:00:00 2001 From: Lukasz Czajka Date: Mon, 12 Feb 2024 15:11:42 +0100 Subject: [PATCH] style improvements --- app/Commands/Dev/Asm/Compile.hs | 4 +- app/Commands/Dev/Core/Compile/Base.hs | 2 +- app/Commands/Dev/Tree/Compile/Base.hs | 2 +- src/Juvix/Compiler/Reg/Extra.hs | 43 +++++++++---------- src/Juvix/Compiler/Reg/Pretty.hs | 2 +- src/Juvix/Compiler/Reg/Pretty/Base.hs | 26 +++++------ .../Tree/Translation/FromSource/Base.hs | 4 +- 7 files changed, 41 insertions(+), 42 deletions(-) diff --git a/app/Commands/Dev/Asm/Compile.hs b/app/Commands/Dev/Asm/Compile.hs index c2f4dc3055..3c01db6b7d 100644 --- a/app/Commands/Dev/Asm/Compile.hs +++ b/app/Commands/Dev/Asm/Compile.hs @@ -33,7 +33,7 @@ runCommand opts = do $ tab tab' <- getRight r let code = Reg.ppPrint tab' tab' - embed @IO $ writeFileEnsureLn regFile code + writeFileEnsureLn regFile code _ -> case run $ runReader entryPoint $ runError $ asmToMiniC tab of Left err -> exitJuvixError err @@ -41,7 +41,7 @@ runCommand opts = do buildDir <- askBuildDir ensureDir buildDir cFile <- inputCFile file - embed @IO $ writeFileEnsureLn cFile _resultCCode + writeFileEnsureLn cFile _resultCCode outfile <- Compile.outputFile opts file Compile.runCommand opts diff --git a/app/Commands/Dev/Core/Compile/Base.hs b/app/Commands/Dev/Core/Compile/Base.hs index 9460f33e76..5f2daa6251 100644 --- a/app/Commands/Dev/Core/Compile/Base.hs +++ b/app/Commands/Dev/Core/Compile/Base.hs @@ -89,7 +89,7 @@ runGebPipeline pa@PipelineArg {..} = do _lispPackageEntry = "*entry*" } Geb.Result {..} <- getRight (run (runReader entryPoint (runError (coreToGeb spec _pipelineArgModule :: Sem '[Error JuvixError, Reader EntryPoint] Geb.Result)))) - embed @IO $ writeFileEnsureLn gebFile _resultCode + writeFileEnsureLn gebFile _resultCode runVampIRPipeline :: forall r. diff --git a/app/Commands/Dev/Tree/Compile/Base.hs b/app/Commands/Dev/Tree/Compile/Base.hs index 550c5fde53..71421c5dc9 100644 --- a/app/Commands/Dev/Tree/Compile/Base.hs +++ b/app/Commands/Dev/Tree/Compile/Base.hs @@ -59,7 +59,7 @@ runCPipeline pa@PipelineArg {..} = do . runError @JuvixError $ treeToMiniC _pipelineArgTable cFile <- inputCFile _pipelineArgFile - embed @IO $ writeFileEnsureLn cFile _resultCCode + writeFileEnsureLn cFile _resultCCode outfile <- Compile.outputFile _pipelineArgOptions _pipelineArgFile Compile.runCommand _pipelineArgOptions diff --git a/src/Juvix/Compiler/Reg/Extra.hs b/src/Juvix/Compiler/Reg/Extra.hs index 2740eac58e..97233b50a7 100644 --- a/src/Juvix/Compiler/Reg/Extra.hs +++ b/src/Juvix/Compiler/Reg/Extra.hs @@ -50,14 +50,13 @@ computeMaxStackHeight lims = maximum . map go (computeMaxStackHeight lims _instrBranchTrue) (computeMaxStackHeight lims _instrBranchFalse) Case InstrCase {..} -> - max - ( maximum - ( map - (computeMaxStackHeight lims . (^. caseBranchCode)) - _instrCaseBranches - ) + maximum1 + ( maybe 0 (computeMaxStackHeight lims) _instrCaseDefault + :| ( map + (computeMaxStackHeight lims . (^. caseBranchCode)) + _instrCaseBranches + ) ) - (maybe 0 (computeMaxStackHeight lims) _instrCaseDefault) Block InstrBlock {..} -> computeMaxStackHeight lims _instrBlockCode @@ -91,14 +90,13 @@ computeMaxCallClosuresArgsNum = maximum . map go (computeMaxCallClosuresArgsNum _instrBranchTrue) (computeMaxCallClosuresArgsNum _instrBranchFalse) Case InstrCase {..} -> - max - ( maximum - ( map - (computeMaxCallClosuresArgsNum . (^. caseBranchCode)) - _instrCaseBranches - ) + maximum1 + ( maybe 0 computeMaxCallClosuresArgsNum _instrCaseDefault + :| ( map + (computeMaxCallClosuresArgsNum . (^. caseBranchCode)) + _instrCaseBranches + ) ) - (maybe 0 computeMaxCallClosuresArgsNum _instrCaseDefault) Block InstrBlock {..} -> computeMaxCallClosuresArgsNum _instrBlockCode @@ -191,14 +189,13 @@ computeLocalVarsNum = maximum . map go (computeLocalVarsNum _instrBranchTrue) (computeLocalVarsNum _instrBranchFalse) Case InstrCase {..} -> - max - ( maximum - ( map - (computeLocalVarsNum . (^. caseBranchCode)) - _instrCaseBranches - ) + maximum1 + ( maybe 0 computeLocalVarsNum _instrCaseDefault + :| ( map + (computeLocalVarsNum . (^. caseBranchCode)) + _instrCaseBranches + ) ) - (maybe 0 computeLocalVarsNum _instrCaseDefault) Block InstrBlock {..} -> computeLocalVarsNum _instrBlockCode @@ -261,9 +258,9 @@ computeExtraInfo lims tab = _extraInfoMaxArgsNum = maximum (map (^. functionArgsNum) (HashMap.elems (tab ^. infoFunctions))), _extraInfoMaxCallClosuresArgsNum = - maximum + maximum1 ( lims ^. limitsSpecialisedApply - : map (computeMaxCallClosuresArgsNum . (^. functionCode)) (HashMap.elems (tab ^. infoFunctions)) + :| map (computeMaxCallClosuresArgsNum . (^. functionCode)) (HashMap.elems (tab ^. infoFunctions)) ), _extraInfoConstrsNum = length (userConstrs tab) + lims ^. limitsBuiltinUIDsNum, diff --git a/src/Juvix/Compiler/Reg/Pretty.hs b/src/Juvix/Compiler/Reg/Pretty.hs index a977a8af0a..47fe4d9e98 100644 --- a/src/Juvix/Compiler/Reg/Pretty.hs +++ b/src/Juvix/Compiler/Reg/Pretty.hs @@ -25,4 +25,4 @@ ppTrace :: (PrettyCode c) => InfoTable -> c -> Text ppTrace tab = ppTrace' (defaultOptions tab) ppPrint :: (PrettyCode c) => InfoTable -> c -> Text -ppPrint tab = show . ppOutDefault tab +ppPrint tab = toPlainText . ppOutDefault tab diff --git a/src/Juvix/Compiler/Reg/Pretty/Base.hs b/src/Juvix/Compiler/Reg/Pretty/Base.hs index 41de3b2dab..6b5a490076 100644 --- a/src/Juvix/Compiler/Reg/Pretty/Base.hs +++ b/src/Juvix/Compiler/Reg/Pretty/Base.hs @@ -25,9 +25,9 @@ class PrettyCode c where instance PrettyCode VarRef where ppCode VarRef {..} = case _varRefName of Just n -> return $ variable (quoteName n) - Nothing -> case _varRefGroup of - VarGroupArgs -> return $ ppRef Str.arg _varRefIndex - VarGroupLocal -> return $ ppRef Str.tmp _varRefIndex + Nothing -> return $ case _varRefGroup of + VarGroupArgs -> ppRef Str.arg _varRefIndex + VarGroupLocal -> ppRef Str.tmp _varRefIndex where ppRef :: Text -> Index -> Doc Ann ppRef str off = variable str <> brackets (integer off) @@ -45,16 +45,16 @@ instance PrettyCode Value where VRef x -> ppCode x instance PrettyCode Opcode where - ppCode = \case - OpIntAdd -> return $ primitive Str.add_ - OpIntSub -> return $ primitive Str.sub_ - OpIntMul -> return $ primitive Str.mul_ - OpIntDiv -> return $ primitive Str.div_ - OpIntMod -> return $ primitive Str.mod_ - OpIntLt -> return $ primitive Str.lt_ - OpIntLe -> return $ primitive Str.le_ - OpEq -> return $ primitive Str.eq - OpStrConcat -> return $ primitive Str.instrStrConcat + ppCode op = return $ case op of + OpIntAdd -> primitive Str.add_ + OpIntSub -> primitive Str.sub_ + OpIntMul -> primitive Str.mul_ + OpIntDiv -> primitive Str.div_ + OpIntMod -> primitive Str.mod_ + OpIntLt -> primitive Str.lt_ + OpIntLe -> primitive Str.le_ + OpEq -> primitive Str.eq + OpStrConcat -> primitive Str.instrStrConcat instance PrettyCode BinaryOp where ppCode BinaryOp {..} = do diff --git a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs b/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs index bf63cb9ba9..2f610ef0e7 100644 --- a/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs +++ b/src/Juvix/Compiler/Tree/Translation/FromSource/Base.hs @@ -350,9 +350,11 @@ functionBody parseCode' argnames = do let updateNames :: LocalNameMap d -> LocalNameMap d updateNames names = foldr - (\(mn, idx) h -> maybe h (\n -> HashMap.insert n ((sig ^. parserSigArgRef) idx (Just n)) h) mn) + (\(mname, idx) names' -> maybe names' (updateWithArgRef names' idx) mname) names (zip argnames [0 ..]) + updateWithArgRef :: LocalNameMap d -> Int -> Text -> LocalNameMap d + updateWithArgRef names idx name = HashMap.insert name ((sig ^. parserSigArgRef) idx (Just name)) names localS (over localParamsNameMap updateNames) parseCode' memRef ::