-
Notifications
You must be signed in to change notification settings - Fork 51
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
* Closes #2440
- Loading branch information
Showing
8 changed files
with
221 additions
and
16 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
70 changes: 70 additions & 0 deletions
70
src/Juvix/Compiler/Core/Transformation/Optimize/CasePermutation.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,70 @@ | ||
| module Juvix.Compiler.Core.Transformation.Optimize.CasePermutation (casePermutation) where | ||
|
|
||
| import Data.HashMap.Strict qualified as HashMap | ||
| import Data.HashSet qualified as HashSet | ||
| import Juvix.Compiler.Core.Extra | ||
| import Juvix.Compiler.Core.Transformation.Base | ||
|
|
||
| isConstructorTree :: InfoTable -> Case -> Node -> Bool | ||
| isConstructorTree tab c node = case run $ runFail $ go mempty node of | ||
| Just ctrsMap -> | ||
| all (checkOne ctrsMap) tags && checkDefault ctrsMap (c ^. caseDefault) | ||
| Nothing -> False | ||
| where | ||
| tags = map (^. caseBranchTag) (c ^. caseBranches) | ||
| tagMap = HashMap.fromList (map (\br -> (br ^. caseBranchTag, br ^. caseBranchBody)) (c ^. caseBranches)) | ||
|
|
||
| checkOne :: HashMap Tag Int -> Tag -> Bool | ||
| checkOne ctrsMap tag = case HashMap.lookup tag ctrsMap of | ||
| Just 1 -> True | ||
| Nothing -> True | ||
| _ -> isImmediate tab (fromJust $ HashMap.lookup tag tagMap) | ||
|
|
||
| checkDefault :: HashMap Tag Int -> Maybe Node -> Bool | ||
| checkDefault ctrsMap = \case | ||
| Just d -> | ||
| sum (HashMap.filterWithKey (\k _ -> not (HashSet.member k tags')) ctrsMap) <= 1 | ||
| || isImmediate tab d | ||
| where | ||
| tags' = HashSet.fromList tags | ||
| Nothing -> True | ||
|
|
||
| go :: (Member Fail r) => HashMap Tag Int -> Node -> Sem r (HashMap Tag Int) | ||
| go ctrs = \case | ||
| NCtr Constr {..} -> | ||
| return $ HashMap.alter (Just . maybe 1 (+ 1)) _constrTag ctrs | ||
| NCase Case {..} -> do | ||
| ctrs' <- maybe (return ctrs) (go ctrs) _caseDefault | ||
| foldM go ctrs' (map (^. caseBranchBody) _caseBranches) | ||
| _ -> | ||
| fail | ||
|
|
||
| convertNode :: InfoTable -> Node -> Node | ||
| convertNode tab = dmap go | ||
| where | ||
| go :: Node -> Node | ||
| go node = case node of | ||
| NCase c@Case {..} -> case _caseValue of | ||
| NCase c' | ||
| | isConstructorTree tab c _caseValue -> | ||
| NCase | ||
| c' | ||
| { _caseBranches = map permuteBranch (c' ^. caseBranches), | ||
| _caseDefault = fmap (mkBody c) (c' ^. caseDefault) | ||
| } | ||
| where | ||
| permuteBranch :: CaseBranch -> CaseBranch | ||
| permuteBranch br@CaseBranch {..} = | ||
| case shift _caseBranchBindersNum (NCase c {_caseValue = mkBottom'}) of | ||
| NCase cs -> | ||
| over caseBranchBody (mkBody cs) br | ||
| _ -> impossible | ||
|
|
||
| mkBody :: Case -> Node -> Node | ||
| mkBody cs n = NCase cs {_caseValue = n} | ||
| _ -> | ||
| node | ||
| _ -> node | ||
|
|
||
| casePermutation :: InfoTable -> InfoTable | ||
| casePermutation tab = mapAllNodes (convertNode tab) tab |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
95 changes: 95 additions & 0 deletions
95
src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyComparisons.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,95 @@ | ||
| module Juvix.Compiler.Core.Transformation.Optimize.SimplifyComparisons (simplifyComparisons) where | ||
|
|
||
| import Juvix.Compiler.Core.Extra | ||
| import Juvix.Compiler.Core.Transformation.Base | ||
|
|
||
| convertNode :: InfoTable -> Node -> Node | ||
| convertNode tab = dmap go | ||
| where | ||
| boolSym = lookupConstructorInfo tab (BuiltinTag TagTrue) ^. constructorInductive | ||
|
|
||
| go :: Node -> Node | ||
| go node = case node of | ||
| NCase c@Case {..} | ||
| | isCaseBoolean _caseBranches -> | ||
| translateCaseIf goIf c | ||
| _ -> node | ||
|
|
||
| goIf :: Node -> Node -> Node -> Node | ||
| goIf v b1 b2 = case v of | ||
| NBlt blt@BuiltinApp {..} | ||
| | OpEq <- _builtinAppOp -> | ||
| case b2 of | ||
| NCase c@Case {..} | ||
| | isCaseBoolean _caseBranches -> | ||
| translateCaseIf (goCmp v b1) c | ||
| NBlt blt' | ||
| | OpIntLt <- blt' ^. builtinAppOp, | ||
| blt ^. builtinAppArgs == blt' ^. builtinAppArgs -> | ||
| if | ||
| | isFalseConstr b1 -> | ||
| b2 | ||
| | isTrueConstr b1 -> | ||
| NBlt blt {_builtinAppOp = OpIntLe} | ||
| | otherwise -> | ||
| mkIf' boolSym v b1 b2 | ||
| _ -> | ||
| mkIf' boolSym v b1 b2 | ||
| | OpIntLt <- _builtinAppOp, | ||
| isFalseConstr b1 && isTrueConstr b2 -> | ||
| NBlt | ||
| blt | ||
| { _builtinAppOp = OpIntLe, | ||
| _builtinAppArgs = reverse _builtinAppArgs | ||
| } | ||
| | OpIntLe <- _builtinAppOp, | ||
| isFalseConstr b1 && isTrueConstr b2 -> | ||
| NBlt | ||
| blt | ||
| { _builtinAppOp = OpIntLt, | ||
| _builtinAppArgs = reverse _builtinAppArgs | ||
| } | ||
| _ -> | ||
| mkIf' boolSym v b1 b2 | ||
|
|
||
| goCmp :: Node -> Node -> Node -> Node -> Node -> Node | ||
| goCmp v b1 v' b1' b2' = case (v, v') of | ||
| (NBlt blt, NBlt blt') | ||
| | (OpEq, OpIntLt) <- (blt ^. builtinAppOp, blt' ^. builtinAppOp), | ||
| blt ^. builtinAppArgs == blt' ^. builtinAppArgs -> | ||
| if | ||
| | isFalseConstr b1 && isTrueConstr b1' && isFalseConstr b2' -> | ||
| v' | ||
| | isTrueConstr b1 && isFalseConstr b1' && isFalseConstr b2' -> | ||
| v | ||
| | isTrueConstr b1 && isTrueConstr b1' && isFalseConstr b2' -> | ||
| NBlt blt {_builtinAppOp = OpIntLe} | ||
| | isFalseConstr b1 && isFalseConstr b1' && isTrueConstr b2' -> | ||
| NBlt | ||
| blt | ||
| { _builtinAppOp = OpIntLt, | ||
| _builtinAppArgs = reverse (blt ^. builtinAppArgs) | ||
| } | ||
| | isTrueConstr b1 && isFalseConstr b1' && isTrueConstr b2' -> | ||
| NBlt | ||
| blt | ||
| { _builtinAppOp = OpIntLe, | ||
| _builtinAppArgs = reverse (blt ^. builtinAppArgs) | ||
| } | ||
| | isFalseConstr b1 && isTrueConstr b1' && isTrueConstr b2' -> | ||
| mkIf' boolSym v b1 b1' | ||
| | b1 == b2' -> | ||
| mkIf' boolSym v' b1' b2' | ||
| | b1' == b2' -> | ||
| mkIf' boolSym v b1 b1' | ||
| | b1 == b1' -> | ||
| mkIf' boolSym (NBlt blt {_builtinAppOp = OpIntLe}) b1 b2' | ||
| | otherwise -> | ||
| theIfs | ||
| _ -> | ||
| theIfs | ||
| where | ||
| theIfs = mkIf' boolSym v b1 (mkIf' boolSym v' b1' b2') | ||
|
|
||
| simplifyComparisons :: InfoTable -> InfoTable | ||
| simplifyComparisons tab = mapAllNodes (convertNode tab) tab |
31 changes: 20 additions & 11 deletions
31
src/Juvix/Compiler/Core/Transformation/Optimize/SimplifyIfs.hs
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -1,21 +1,30 @@ | ||
| module Juvix.Compiler.Core.Transformation.Optimize.SimplifyIfs (simplifyIfs) where | ||
| module Juvix.Compiler.Core.Transformation.Optimize.SimplifyIfs (simplifyIfs, simplifyIfs') where | ||
|
|
||
| import Data.List qualified as List | ||
| import Juvix.Compiler.Core.Extra | ||
| import Juvix.Compiler.Core.Transformation.Base | ||
|
|
||
| convertNode :: Node -> Node | ||
| convertNode = umap go | ||
| convertNode :: Bool -> InfoTable -> Node -> Node | ||
| convertNode bFast tab = umap go | ||
| where | ||
| boolSym = lookupConstructorInfo tab (BuiltinTag TagTrue) ^. constructorInductive | ||
|
|
||
| go :: Node -> Node | ||
| go node = case node of | ||
| NCase Case {..} | ||
| | isCaseBoolean _caseBranches | ||
| && all (== List.head bodies) (List.tail bodies) -> | ||
| List.head bodies | ||
| where | ||
| bodies = map (^. caseBranchBody) _caseBranches ++ maybeToList _caseDefault | ||
| NCase c@Case {..} | ||
| | isCaseBoolean _caseBranches -> | ||
| translateCaseIf goIf c | ||
| _ -> node | ||
|
|
||
| goIf :: Node -> Node -> Node -> Node | ||
| goIf v b1 b2 | ||
| | isTrueConstr b1 && isFalseConstr b2 = v | ||
| | bFast && isTrueConstr b1 && isTrueConstr b2 = b1 | ||
| | bFast && isFalseConstr b1 && isFalseConstr b2 = b1 | ||
| | not bFast && b1 == b2 = b1 | ||
| | otherwise = mkIf' boolSym v b1 b2 | ||
|
|
||
| simplifyIfs' :: Bool -> InfoTable -> InfoTable | ||
| simplifyIfs' bFast tab = mapAllNodes (convertNode bFast tab) tab | ||
|
|
||
| simplifyIfs :: InfoTable -> InfoTable | ||
| simplifyIfs = mapAllNodes convertNode | ||
| simplifyIfs = simplifyIfs' False |