From 43409a58e99faed334abc734280865479e3dc355 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Sun, 24 Apr 2022 19:06:17 +0100 Subject: [PATCH 01/17] Share bodies instead of copying them This fixes a major problem with the previous version: there exist pathological programs that lead to an exponential amount of copying. This improvement comes with the small cost that non-pathological programs take longer to compile. Sharing is observed by first converting the program into an interaction net, which is then reduced into the output program. The reduction algorithm used is that of the Lambdascope implementation extended with FFI nodes and the necessary rules to reduce them. https://web.archive.org/web/20170706084403/http://www.phil.uu.nl/~oostrom/publication/pdf/lambdascope.pdf For ease of debugging, a generic backend language was also introduced to decouple most of the compiler from LLVM. This may also, in future, allow alternative backends to be developed. --- default.nix | 1 + elemental.cabal | 7 + src/Control/Effect/ModuleBuilder.hs | 5 +- src/Language/Elemental.hs | 8 +- src/Language/Elemental/AST/Expr.hs | 241 ++--- src/Language/Elemental/AST/Type.hs | 48 +- src/Language/Elemental/Backend.hs | 335 +++++++ src/Language/Elemental/Backend/LLVM.hs | 234 +++++ src/Language/Elemental/Emit.hs | 725 ++++----------- src/Language/Elemental/InteractionNet.hs | 1027 ++++++++++++++++++++++ src/Language/Elemental/Parser.hs | 3 + src/Language/Elemental/Pretty.hs | 29 +- src/Language/Elemental/TypeCheck.hs | 21 +- test/Gen.hs | 10 +- test/Golden.hs | 196 ++++- test/Golden/.gitignore | 2 + test/Golden/CataStaticDouble.elem | 23 + test/Golden/CataStaticDouble.opt.ll | 12 + test/Golden/CataStaticTwice.elem | 22 + test/Golden/CataStaticTwice.opt.ll | 16 + test/Golden/FunctionInIO.opt.ll | 12 +- test/Golden/IOInIO.elem | 11 + test/Golden/IOInIO.opt.ll | 9 + test/Golden/NestedBranch.elem | 21 + test/Golden/NestedBranch.opt.ll | 16 + test/Golden/NestedBranch2.elem | 25 + test/Golden/NestedBranch2.opt.ll | 22 + test/Golden/ParserQuirks.opt.ll | 0 test/Golden/SelfReference.elem | 15 + test/Golden/SelfReference.opt.ll | 9 + test/Golden/ShareBindCont.elem | 17 + test/Golden/ShareBindCont.opt.ll | 15 + test/Golden/ShareFunction.elem | 13 + test/Golden/ShareFunction.opt.ll | 9 + test/Golden/ShareFunction2.elem | 10 + test/Golden/ShareFunction2.opt.ll | 9 + test/Golden/ShareIO.elem | 30 + test/Golden/ShareIO.opt.ll | 32 + test/Golden/SimpleArgs.opt.ll | 8 +- test/Main.hs | 3 +- test/Pretty.hs | 5 +- test/Util.hs | 15 +- 42 files changed, 2536 insertions(+), 735 deletions(-) create mode 100644 src/Language/Elemental/Backend.hs create mode 100644 src/Language/Elemental/Backend/LLVM.hs create mode 100644 src/Language/Elemental/InteractionNet.hs create mode 100644 test/Golden/CataStaticDouble.elem create mode 100644 test/Golden/CataStaticDouble.opt.ll create mode 100644 test/Golden/CataStaticTwice.elem create mode 100644 test/Golden/CataStaticTwice.opt.ll create mode 100644 test/Golden/IOInIO.elem create mode 100644 test/Golden/IOInIO.opt.ll create mode 100644 test/Golden/NestedBranch.elem create mode 100644 test/Golden/NestedBranch.opt.ll create mode 100644 test/Golden/NestedBranch2.elem create mode 100644 test/Golden/NestedBranch2.opt.ll create mode 100644 test/Golden/ParserQuirks.opt.ll create mode 100644 test/Golden/SelfReference.elem create mode 100644 test/Golden/SelfReference.opt.ll create mode 100644 test/Golden/ShareBindCont.elem create mode 100644 test/Golden/ShareBindCont.opt.ll create mode 100644 test/Golden/ShareFunction.elem create mode 100644 test/Golden/ShareFunction.opt.ll create mode 100644 test/Golden/ShareFunction2.elem create mode 100644 test/Golden/ShareFunction2.opt.ll create mode 100644 test/Golden/ShareIO.elem create mode 100644 test/Golden/ShareIO.opt.ll diff --git a/default.nix b/default.nix index 353bd00..cee7e30 100644 --- a/default.nix +++ b/default.nix @@ -11,6 +11,7 @@ compiler.developPackage { modifier = drv: pkgs.haskell.lib.compose.addBuildTools [ pkgs.haskellPackages.cabal-install + pkgs.haskell-language-server # LLVM CLI tools for local testing purposes. pkgs.llvm_9 # For viewing heap profiles (mainly ps2pdf). diff --git a/elemental.cabal b/elemental.cabal index 72b015a..8778027 100644 --- a/elemental.cabal +++ b/elemental.cabal @@ -33,8 +33,10 @@ common shared , bytestring ^>= 0.10 , containers ^>= 0.6 , data-fix ^>= 0.3 + , dlist ^>= 1.0 , fused-effects ^>= 1.1 , integer-logarithms ^>= 1.0 + , lens ^>= 4.19 , llvm-hs == 9.0.1 , llvm-hs-pure ^>= 9.0 , megaparsec ^>= 9.0 @@ -42,6 +44,7 @@ common shared , tagged ^>= 0.8 , text ^>= 1.2 , text-short ^>= 0.1 + , transformers ^>= 0.5 default-language: Haskell2010 ghc-options: -Wall @@ -70,9 +73,12 @@ library , Language.Elemental.AST.Program , Language.Elemental.AST.Type , Language.Elemental.AST.Unchecked + , Language.Elemental.Backend + , Language.Elemental.Backend.LLVM , Language.Elemental.Diagnostic , Language.Elemental.Emit , Language.Elemental.Location + , Language.Elemental.InteractionNet , Language.Elemental.Parser , Language.Elemental.Pretty , Language.Elemental.Primitive @@ -116,5 +122,6 @@ test-suite test , tasty ^>= 1.4 , tasty-golden ^>= 2.3 , tasty-hedgehog ^>= 1.1 + , tasty-hunit ^>= 0.10 ghc-options: -threaded diff --git a/src/Control/Effect/ModuleBuilder.hs b/src/Control/Effect/ModuleBuilder.hs index b9173c4..355e12e 100644 --- a/src/Control/Effect/ModuleBuilder.hs +++ b/src/Control/Effect/ModuleBuilder.hs @@ -57,10 +57,12 @@ function -- ^ The types of the function arguments. -> Type -- ^ The return type of the function. + -> Linkage + -- ^ The linkage of the function. -> ([Operand] -> IRBuilderC m ()) -- ^ A function that builds the function's basic blocks from its arguments. -> m Operand -function nm argTys retTy body = do +function nm argTys retTy link body = do (blocks, paramNames) <- runIRBuilder emptyIRBuilder $ do paramNames <- traverse (const fresh) argTys body $ zipWith LocalReference argTys paramNames @@ -71,6 +73,7 @@ function nm argTys retTy body = do = (($ []) <$> zipWith Parameter argTys paramNames, False) , returnType = retTy , basicBlocks = blocks + , linkage = link } funTy = ptr $ FunctionType retTy argTys False ConstantOperand (GlobalReference funTy nm) <$ emitDefn def diff --git a/src/Language/Elemental.hs b/src/Language/Elemental.hs index b46f3b2..8a543b7 100644 --- a/src/Language/Elemental.hs +++ b/src/Language/Elemental.hs @@ -33,6 +33,7 @@ module Language.Elemental -- * Emitting -- $emitting , module Language.Elemental.Emit + , module Language.Elemental.InteractionNet ) where import Data.Version (Version) @@ -45,6 +46,7 @@ import Language.Elemental.AST.Type import Language.Elemental.AST.Unchecked import Language.Elemental.Diagnostic import Language.Elemental.Emit +import Language.Elemental.InteractionNet import Language.Elemental.Location import Language.Elemental.Parser import Language.Elemental.Pretty @@ -116,7 +118,11 @@ version = Paths.version -} {- $emitting - Programs can be emitted as LLVM using 'emitProgram'. + Programs can be emitted as interaction nets using 'emitProgram'. These can + then be compiled with 'compileINet'. This will output a generic backend + representation, which can finally be converted into LLVM using + "Language.Elemental.Backend.LLVM" or into some other target language by + manually folding the representation. The compiler also exposes its other emitting functions, however their interface may be more volatile as there's no clear use case for them. diff --git a/src/Language/Elemental/AST/Expr.hs b/src/Language/Elemental/AST/Expr.hs index 1b6cfb8..e4dab6e 100644 --- a/src/Language/Elemental/AST/Expr.hs +++ b/src/Language/Elemental/AST/Expr.hs @@ -33,7 +33,7 @@ module Language.Elemental.AST.Expr , pattern (:@) , pattern (:\) -- * Marshalling - , LlvmOperandType + , BackendOperandType , IsOpType , sIsOpType , AllIsOpType @@ -76,15 +76,13 @@ module Language.Elemental.AST.Expr import Data.Data import Data.Kind qualified as Kind import Data.Void (absurd) -import LLVM.AST qualified as LLVM -import LLVM.AST.Constant qualified as LLVM.Constant import Numeric (showHex) import Numeric.Natural (Natural) import Prettyprinter import Unsafe.Coerce qualified as Unsafe -import Control.Effect.IRBuilder import Language.Elemental.AST.Type +import Language.Elemental.Backend qualified as Backend import Language.Elemental.Singleton @@ -119,15 +117,20 @@ data Expr tscope scope t where :: (MarshallableType tx, IsOpType (Marshall tx) ~ 'True) => Address -> SPointerKind pk -> SType tscope tx -> Expr tscope scope ('PointerType pk tx) - -- | A pure LLVM operand. This is an internal expression. - LlvmOperand - :: SLlvmType lt -> LlvmOperandType lt - -> Expr tscope scope ('LlvmType lt) - -- | An LLVM operand in @IO@. This is an internal expression. - LlvmIO - :: SLlvmType lt - -> (forall sig m. Has IRBuilder sig m => m (LlvmOperandType lt)) - -> Expr tscope scope ('IOType ('LlvmType lt)) + -- | A pure backend operand. This is an internal expression. + BackendOperand + :: SBackendType lt -> Backend.Operand + -> Expr tscope scope ('BackendType lt) + -- | An backend operand in @IO@. This is an internal expression. + BackendIO + :: SBackendType lt + -- -> (forall sig m. Has IRBuilder sig m => m (BackendOperandType lt)) + -> Backend.Body + -> Expr tscope scope ('IOType ('BackendType lt)) + BackendPIO + :: SBackendType lta -> SBackendType lt + -> (Backend.Operand -> Backend.Instruction) + -> Expr tscope scope ('BackendType lta :-> 'IOType ('BackendType lt)) -- | The @pureIO@ primitive. This is an internal expression. PureIO :: Expr tscope scope PureIOType -- | The @bindIO@ primitive. This is an internal expression. @@ -138,21 +141,24 @@ data Expr tscope scope t where StorePointer :: Expr tscope scope StorePointerType -- | A call of a foreign function. This is an internal expression. Call - :: AllIsOpType ltargs ~ 'True => LLVM.CallableOperand -> [LLVM.Operand] - -> SList SLlvmType ltargs -> SLlvmType ltret + :: AllIsOpType ltargs ~ 'True => Backend.Name + -> SList SBackendType ltargs -> SBackendType ltret -> Expr tscope scope (BuildForeignType ltargs ltret) -- | Extracts a single bit from an integer. This is an internal expression. IsolateBit :: CmpNat idx size ~ 'LT => SNat idx -> SNat size -> Expr tscope scope - ('LlvmType ('LlvmInt size) :-> 'LlvmType ('LlvmInt ('Succ 'Zero))) + ( 'BackendType ('BackendInt size) + :-> 'BackendType ('BackendInt ('Succ 'Zero)) + ) -- | Inserts a bit as the MSB of an integer. This is an internal expression. InsertBit :: SNat size -> Expr tscope scope - ('LlvmType ('LlvmInt ('Succ 'Zero)) :-> 'LlvmType ('LlvmInt size) - :-> 'LlvmType ('LlvmInt ('Succ size))) - -- | Converts an LLVM @i1@ into a 'BitType'. This is an internal expression. - TestBit - :: Expr tscope scope ('LlvmType ('LlvmInt ('Succ 'Zero))) - -> Expr tscope scope BitType + ( 'BackendType ('BackendInt ('Succ 'Zero)) + :-> 'BackendType ('BackendInt size) + :-> 'BackendType ('BackendInt ('Succ size)) + ) + -- | Converts an @i1@ into a 'BitType'. This is an internal expression. + TestBit :: Expr tscope scope + ('BackendType ('BackendInt ('Succ 'Zero)) :-> BitType) -- | Pointer addresses in the AST. newtype Address = Address { getAddress :: Natural } @@ -198,47 +204,48 @@ pattern (:\) pattern tx :\ ey = Lam tx ey infixr 0 :\ --- | Type synonym to convert any t'LlvmType' into its compiler representation. -type LlvmOperandType :: LlvmType -> Kind.Type -type LlvmOperandType lt = If (IsOpType lt) LLVM.Operand () +-- | Type synonym to convert a t'BackendType' into its compiler representation. +type BackendOperandType :: BackendType -> Kind.Type +type BackendOperandType lt = If (IsOpType lt) Backend.Operand () --- | Is the t'LlvmType' a legal LLVM operand type? Notably, @void@ is not. -type IsOpType :: LlvmType -> Bool +-- | Is the t'BackendType' a legal backend operand type? Notably, @i0@ is not. +type IsOpType :: BackendType -> Bool type family IsOpType lt where - IsOpType ('LlvmInt size) = SwitchOrd (CmpNat size 'Zero) Stuck 'False 'True + IsOpType ('BackendInt size) + = SwitchOrd (CmpNat size 'Zero) Stuck 'False 'True -- | Singleton version of 'IsOpType'. -sIsOpType :: SLlvmType lt -> SBool (IsOpType lt) -sIsOpType (SLlvmInt size) = case sCmpNat size SZero of +sIsOpType :: SBackendType lt -> SBool (IsOpType lt) +sIsOpType (SBackendInt size) = case sCmpNat size SZero of SLT -> absurd $ zeroNoLT size Refl SEQ -> SFalse SGT -> STrue --- | Is every t'LlvmType' in a list a legal LLVM operand type? -type AllIsOpType :: [LlvmType] -> Bool +-- | Is every t'BackendType' in a list a legal backend operand type? +type AllIsOpType :: [BackendType] -> Bool type family AllIsOpType lts where AllIsOpType '[] = 'True AllIsOpType (lt ': lts) = IsOpType lt && AllIsOpType lts -- | Singleton version of 'AllIsOpType'. -sAllIsOpType :: SList SLlvmType lts -> SBool (AllIsOpType lts) +sAllIsOpType :: SList SBackendType lts -> SBool (AllIsOpType lts) sAllIsOpType SNil = STrue sAllIsOpType (lt :^ lts) = sIsOpType lt &&^ sAllIsOpType lts -- | The type has an isomorphic foreign type. type HasForeignType :: Type -> Kind.Constraint class AllIsOpType (ForeignArgs t) ~ 'True => HasForeignType t where - -- | The argument t'LlvmType' of the foreign type. - type ForeignArgs t :: [LlvmType] + -- | The argument t'BackendType' of the foreign type. + type ForeignArgs t :: [BackendType] -- | Singleton version of 'ForeignArgs'. - sForeignArgs :: SType tscope t -> SList SLlvmType (ForeignArgs t) + sForeignArgs :: SType tscope t -> SList SBackendType (ForeignArgs t) - -- | The return t'LlvmType' of the foreign type. - type ForeignRet t :: LlvmType + -- | The return t'BackendType' of the foreign type. + type ForeignRet t :: BackendType -- | Singleton version of 'ForeignRet'. - sForeignRet :: SType tscope t -> SLlvmType (ForeignRet t) + sForeignRet :: SType tscope t -> SBackendType (ForeignRet t) -- | Wraps the foreign type into the native type. wrapImport @@ -263,15 +270,15 @@ instance MarshallableType t => HasForeignType ('IOType t) where :\ PureIO :@ t :$ marshallIn tscope (t' :^ scope) t (Var SZero)) where - t' = SLlvmType $ sMarshall t + t' = SBackendType $ sMarshall t wrapExport tscope scope (SIOType (t :: SType tscope tx)) x = withProof (subIncElim tscope SZero t' t Refl) $ BindIO :@ t :$ x :@ t' :$ (t :\ PureIO :@ t' :$ marshallOut tscope (t :^ scope) t (Var SZero)) where - t' :: SType tscope ('LlvmType (Marshall tx)) - t' = SLlvmType $ sMarshall t + t' :: SType tscope ('BackendType (Marshall tx)) + t' = SBackendType $ sMarshall t instance (MarshallableType tx, IsOpType (Marshall tx) ~ 'True , HasForeignType ty) => HasForeignType (tx :-> ty) @@ -296,46 +303,49 @@ instance (MarshallableType tx, IsOpType (Marshall tx) ~ 'True :$ marshallIn tscope (tx' :^ scope) tx (Var SZero) ) where - tx' = SLlvmType $ sMarshall tx + tx' = SBackendType $ sMarshall tx -- | The foreign type corresponding to a native type. type ForeignType t = BuildForeignType (ForeignArgs t) (ForeignRet t) --- | Builds a type from a list of argument t'LlvmType' and a return t'LlvmType'. -type BuildForeignType :: [LlvmType] -> LlvmType -> Type +{-| + Builds a type from a list of argument t'BackendType' and a return + t'BackendType'. +-} +type BuildForeignType :: [BackendType] -> BackendType -> Type type family BuildForeignType ltargs ltret where - BuildForeignType '[] ltret = 'IOType ('LlvmType ltret) + BuildForeignType '[] ltret = 'IOType ('BackendType ltret) BuildForeignType (ltarg ': ltargs) ltret - = 'LlvmType ltarg :-> BuildForeignType ltargs ltret + = 'BackendType ltarg :-> BuildForeignType ltargs ltret -- | Singleton version of 'BuildForeignType'. sBuildForeignType - :: SList SLlvmType ltargs -> SLlvmType ltret + :: SList SBackendType ltargs -> SBackendType ltret -> SType tscope (BuildForeignType ltargs ltret) -sBuildForeignType SNil ltret = SIOType $ SLlvmType ltret +sBuildForeignType SNil ltret = SIOType $ SBackendType ltret sBuildForeignType (ltarg :^ ltargs) ltret - = SLlvmType ltarg :-> sBuildForeignType ltargs ltret + = SBackendType ltarg :-> sBuildForeignType ltargs ltret --- | The type is isomorphic to and can be marshalled to and from an t'LlvmType'. +-- | The type is isomorphic to a t'BackendType'. type MarshallableType :: Type -> Kind.Constraint class t ~ Unmarshall (Marshall t) => MarshallableType t where - -- | The t'LlvmType' corresponding to a native type. - type Marshall t :: LlvmType + -- | The t'BackendType' corresponding to a native type. + type Marshall t :: BackendType -- | Singleton version of 'Marshall'. - sMarshall :: SType scope t -> SLlvmType (Marshall t) + sMarshall :: SType scope t -> SBackendType (Marshall t) - -- | Marshalls an expression from the t'LlvmType' to the native type. + -- | Marshalls an expression from the t'BackendType' to the native type. marshallIn :: SNat tscope -> SList (SType tscope) scope -> SType tscope t - -> Expr tscope scope ('LlvmType (Marshall t)) + -> Expr tscope scope ('BackendType (Marshall t)) -> Expr tscope scope t - -- | Marshalls an expression from the native type to the t'LlvmType'. + -- | Marshalls an expression from the native type to the t'BackendType'. marshallOut :: SNat tscope -> SList (SType tscope) scope -> SType tscope t -> Expr tscope scope t - -> Expr tscope scope ('LlvmType (Marshall t)) + -> Expr tscope scope ('BackendType (Marshall t)) -- | Proof that 'Increment' is a no-op, i.e. the type is closed. incMarshall @@ -348,28 +358,30 @@ class t ~ Unmarshall (Marshall t) => MarshallableType t where -> t :~: Substitute idx tsub t instance MarshallableType UnitType where - type Marshall UnitType = 'LlvmInt 'Zero - sMarshall _ = SLlvmInt SZero + type Marshall UnitType = 'BackendInt 'Zero + sMarshall _ = SBackendInt SZero marshallIn _ _ _ _ = TypeLam $ STypeVar SZero :\ Var SZero - marshallOut _ _ _ _ = LlvmOperand (SLlvmInt SZero) () + -- marshallOut _ _ _ _ = BackendOperand (SBackendInt SZero) Backend.Empty + marshallOut _ _ _ = (:$ BackendOperand (SBackendInt SZero) Backend.Empty) + . (:@ SBackendType (SBackendInt SZero)) incMarshall _ _ = Refl subMarshall _ _ _ = Refl instance MarshallableType BitType where - type Marshall BitType = 'LlvmInt ('Succ 'Zero) - sMarshall _ = SLlvmInt $ SSucc SZero + type Marshall BitType = 'BackendInt ('Succ 'Zero) + sMarshall _ = SBackendInt $ SSucc SZero - marshallIn _ _ _ = TestBit + marshallIn _ _ _ = (TestBit :$) - marshallOut _ _ _ x = x :@ SLlvmType lt - :$ LlvmOperand lt (LLVM.ConstantOperand $ LLVM.Constant.Int 1 1) - :$ LlvmOperand lt (LLVM.ConstantOperand $ LLVM.Constant.Int 1 0) + marshallOut _ _ _ x = x :@ SBackendType lt + :$ BackendOperand lt (Backend.Constant Backend.B1) + :$ BackendOperand lt (Backend.Constant Backend.B0) where - lt = SLlvmInt $ SSucc SZero + lt = SBackendInt $ SSucc SZero incMarshall _ _ = Refl @@ -379,8 +391,8 @@ instance (t ~ BitTuple (ArgCount t), ArgCount t ~ 'Succ _n) => MarshallableType ('Forall ((BitType :-> t) :-> 'TypeVar 'Zero)) where type Marshall ('Forall ((BitType :-> t) :-> 'TypeVar 'Zero)) - = 'LlvmInt ('Succ (ArgCount t)) - sMarshall (SForall (SArrow t _)) = SLlvmInt $ sArgCount t + = 'BackendInt ('Succ (ArgCount t)) + sMarshall (SForall (SArrow t _)) = SBackendInt $ sArgCount t marshallIn tscope scope t x = TypeLam $ tx :\ withProof (ltSucc size) ( withProof (insZeroP tx scope') @@ -400,7 +412,7 @@ instance (t ~ BitTuple (ArgCount t), ArgCount t ~ 'Succ _n) :: forall tscope scope n size. (CmpNat n ('Succ size) ~ 'LT) => SNat ('Succ tscope) -> SList (SType ('Succ tscope)) scope -> SNat n -> SNat size - -> Expr ('Succ tscope) scope ('LlvmType ('LlvmInt size)) + -> Expr ('Succ tscope) scope ('BackendType ('BackendInt size)) -> Expr ('Succ tscope) scope (BitTuple n) -> Expr ('Succ tscope) scope ('TypeVar 'Zero) marshallTuple _ _ SZero _ _ er = er @@ -409,7 +421,7 @@ instance (t ~ BitTuple (ArgCount t), ArgCount t ~ 'Succ _n) $ marshallTuple tsc sc idx size' ex $ er :$ marshallIn tsc sc SBitType (IsolateBit idx size' :$ ex) - marshallOut tscope scope t x = x :@ SLlvmType (sMarshall t) + marshallOut tscope scope t x = x :@ SBackendType (sMarshall t) :$ marshallTuple tscope scope size (const $ const id) where size = sArgCount tx @@ -420,10 +432,11 @@ instance (t ~ BitTuple (ArgCount t), ArgCount t ~ 'Succ _n) -> SNat size -> (forall scope'. SList (SType tscope) scope' -> (forall t2. Expr tscope scope t2 -> Expr tscope scope' t2) - -> Expr tscope scope' ('LlvmType ('LlvmInt size)) + -> Expr tscope scope' ('BackendType ('BackendInt size)) -> Expr tscope scope' tr) -> Expr tscope scope (Substitute 'Zero tr (BitTuple size)) - marshallTuple _ sc SZero f = f sc id $ LlvmOperand (SLlvmInt SZero) () + marshallTuple _ sc SZero f + = f sc id $ BackendOperand (SBackendInt SZero) Backend.Empty marshallTuple tsc sc (SSucc size') f = SBitType :\ marshallTuple tsc (SBitType :^ sc) size' (\sc' inc ex -> f sc' (withProof (insZero @BitType sc) @@ -478,23 +491,24 @@ sArgCount (SArrow _ tr) = SSucc $ sArgCount tr sArgCount (SForall _) = SZero sArgCount (SIOType _) = SZero sArgCount (SPointerType _ _) = SZero -sArgCount (SLlvmType _) = SZero +sArgCount (SBackendType _) = SZero {-| - Converts an t'LlvmType' to an isomorphic native type. Inverse of 'Marshall'. + Converts a t'BackendType' to an isomorphic native type. Inverse of + 'Marshall'. -} -type Unmarshall :: LlvmType -> Type +type Unmarshall :: BackendType -> Type type family Unmarshall lt where - Unmarshall ('LlvmInt 'Zero) = 'Forall ('TypeVar 'Zero :-> 'TypeVar 'Zero) - Unmarshall ('LlvmInt ('Succ 'Zero)) = BitType - Unmarshall ('LlvmInt size) = 'Forall (BitTuple size :-> 'TypeVar 'Zero) + Unmarshall ('BackendInt 'Zero) = 'Forall ('TypeVar 'Zero :-> 'TypeVar 'Zero) + Unmarshall ('BackendInt ('Succ 'Zero)) = BitType + Unmarshall ('BackendInt size) = 'Forall (BitTuple size :-> 'TypeVar 'Zero) -- | Singleton version of 'Unmarshall'. -sUnmarshall :: SLlvmType lt -> SType tscope (Unmarshall lt) -sUnmarshall (SLlvmInt SZero) = SForall $ STypeVar SZero :-> STypeVar SZero -sUnmarshall (SLlvmInt (SSucc SZero)) +sUnmarshall :: SBackendType lt -> SType tscope (Unmarshall lt) +sUnmarshall (SBackendInt SZero) = SForall $ STypeVar SZero :-> STypeVar SZero +sUnmarshall (SBackendInt (SSucc SZero)) = SForall $ STypeVar SZero :-> STypeVar SZero :-> STypeVar SZero -sUnmarshall (SLlvmInt size@(SSucc (SSucc _))) +sUnmarshall (SBackendInt size@(SSucc (SSucc _))) = SForall $ sBitTuple size :-> STypeVar SZero -- | Gets the type of an expression. @@ -511,8 +525,9 @@ exprType tscope scope = \case TypeLam ex -> SForall $ exprType (SSucc tscope) (sIncrementAll tscope SZero scope) ex Addr _ pk tx -> SPointerType pk tx - LlvmOperand lt _ -> SLlvmType lt - LlvmIO lt _ -> SIOType $ SLlvmType lt + BackendOperand lt _ -> SBackendType lt + BackendIO lt _ -> SIOType $ SBackendType lt + BackendPIO lta lt _ -> SBackendType lta :-> SIOType (SBackendType lt) PureIO -> SForall $ STypeVar SZero :-> SIOType (STypeVar SZero) BindIO -> SForall $ SIOType (STypeVar SZero) :-> SForall ((STypeVar (SSucc SZero) :-> SIOType (STypeVar SZero)) @@ -521,13 +536,13 @@ exprType tscope scope = \case :-> SIOType (STypeVar SZero) StorePointer -> SForall $ SPointerType SWritePointer (STypeVar SZero) :-> STypeVar SZero :-> SIOType SUnitType - Call _ _ ltargs ltret -> sBuildForeignType ltargs ltret - IsolateBit _ size - -> SLlvmType (SLlvmInt size) :-> SLlvmType (SLlvmInt $ SSucc SZero) - InsertBit size -> SLlvmType (SLlvmInt $ SSucc SZero) - :-> SLlvmType (SLlvmInt size) - :-> SLlvmType (SLlvmInt (SSucc size)) - TestBit _ -> SBitType + Call _ ltargs ltret -> sBuildForeignType ltargs ltret + IsolateBit _ size -> SBackendType (SBackendInt size) + :-> SBackendType (SBackendInt $ SSucc SZero) + InsertBit size -> SBackendType (SBackendInt $ SSucc SZero) + :-> SBackendType (SBackendInt size) + :-> SBackendType (SBackendInt (SSucc size)) + TestBit -> SBackendType (SBackendInt $ SSucc SZero) :-> SBitType -- | Increments every type in a list. type IncrementAll :: Nat -> [Type] -> [Type] @@ -584,16 +599,17 @@ incrementExpr tscope scope idx tnew = \case $ incrementExpr (SSucc tscope) (sIncrementAll tscope SZero scope) idx (Proxy @(Increment 'Zero tnew)) ex Addr addr pk tx -> Addr addr pk tx - LlvmOperand lt op -> LlvmOperand lt op - LlvmIO lt op -> LlvmIO lt op + BackendOperand lt op -> BackendOperand lt op + BackendIO lt op -> BackendIO lt op + BackendPIO lta lt pio -> BackendPIO lta lt pio PureIO -> PureIO BindIO -> BindIO LoadPointer -> LoadPointer StorePointer -> StorePointer - Call fop aops ltargs ltret -> Call fop aops ltargs ltret + Call fop ltargs ltret -> Call fop ltargs ltret IsolateBit bidx size -> IsolateBit bidx size InsertBit size -> InsertBit size - TestBit ex -> TestBit $ incrementExpr tscope scope idx tnew ex + TestBit -> TestBit -- | Substitutes a variable at the given index. substituteExpr @@ -632,16 +648,17 @@ substituteExpr tscope scope idx sub = \case $ substituteExpr (SSucc tscope) (sIncrementAll tscope SZero scope) idx (incrementExprType tscope (sRemove idx scope) SZero sub) ex Addr addr pk tx -> Addr addr pk tx - LlvmOperand lt op -> LlvmOperand lt op - LlvmIO lt op -> LlvmIO lt op + BackendOperand lt op -> BackendOperand lt op + BackendIO lt op -> BackendIO lt op + BackendPIO lta lt pio -> BackendPIO lta lt pio PureIO -> PureIO BindIO -> BindIO LoadPointer -> LoadPointer StorePointer -> StorePointer - Call fop aops ltargs ltret -> Call fop aops ltargs ltret + Call fop ltargs ltret -> Call fop ltargs ltret IsolateBit bidx size -> IsolateBit bidx size InsertBit size -> InsertBit size - TestBit ex -> TestBit $ substituteExpr tscope scope idx sub ex + TestBit -> TestBit -- | Introduces a type variable at the given type index. incrementExprType @@ -669,17 +686,18 @@ incrementExprType tscope scope idx = \case (SSucc idx) ex Addr addr pk tx -> withProof (incMarshall idx tx) $ Addr addr pk $ sIncrement tscope idx tx - LlvmOperand lt op -> LlvmOperand lt op - LlvmIO lt op -> LlvmIO lt op + BackendOperand lt op -> BackendOperand lt op + BackendIO lt op -> BackendIO lt op + BackendPIO lta lt pio -> BackendPIO lta lt pio PureIO -> PureIO BindIO -> BindIO LoadPointer -> LoadPointer StorePointer -> StorePointer - Call fop aops ltargs ltret -> withProof (incForeign idx ltargs ltret) - $ Call fop aops ltargs ltret + Call fop ltargs ltret -> withProof (incForeign idx ltargs ltret) + $ Call fop ltargs ltret IsolateBit bidx size -> IsolateBit bidx size InsertBit size -> InsertBit size - TestBit ex -> TestBit $ incrementExprType tscope scope idx ex + TestBit -> TestBit -- | Substitutes a type variable at the given type index. substituteExprType @@ -707,17 +725,18 @@ substituteExprType tscope scope idx tsub = withProofs $ \case (sIncrement tscope SZero tsub) ex Addr addr pk tx -> withProof (subMarshall idx tsub tx) $ Addr addr pk $ sSubstitute tscope idx tsub tx - LlvmOperand lt op -> LlvmOperand lt op - LlvmIO lt op -> LlvmIO lt op + BackendOperand lt op -> BackendOperand lt op + BackendIO lt op -> BackendIO lt op + BackendPIO lta lt pio -> BackendPIO lta lt pio PureIO -> PureIO BindIO -> BindIO LoadPointer -> LoadPointer StorePointer -> StorePointer - Call fop aops ltargs ltret -> withProof (subForeign idx tsub ltargs ltret) - $ Call fop aops ltargs ltret + Call fop ltargs ltret -> withProof (subForeign idx tsub ltargs ltret) + $ Call fop ltargs ltret IsolateBit bidx size -> IsolateBit bidx size InsertBit size -> InsertBit size - TestBit ex -> TestBit $ substituteExprType tscope scope idx tsub ex + TestBit -> TestBit where {- Adding diff --git a/src/Language/Elemental/AST/Type.hs b/src/Language/Elemental/AST/Type.hs index 7423ff0..68b3025 100644 --- a/src/Language/Elemental/AST/Type.hs +++ b/src/Language/Elemental/AST/Type.hs @@ -18,8 +18,8 @@ module Language.Elemental.AST.Type , SType(..) , PointerKind(..) , SPointerKind(..) - , LlvmType(..) - , SLlvmType(..) + , BackendType(..) + , SBackendType(..) -- * Synonyms , UnitType , pattern SUnitType @@ -62,8 +62,8 @@ data Type | IOType Type -- | A pointer to data of the contained type. | PointerType PointerKind Type - -- | An LLVM operand of the given type. This is an internal type. - | LlvmType LlvmType + -- | A backend operand of the given type. This is an internal type. + | BackendType BackendType {-| Singleton for 'Type'. Used to witness an Elemental type at runtime. @@ -83,8 +83,8 @@ data SType scope t where -- | Singleton constructor for 'PointerType'. SPointerType :: SPointerKind pk -> SType scope tx -> SType scope ('PointerType pk tx) - -- | Singleton constructor for v'LlvmType'. - SLlvmType :: SLlvmType lt -> SType scope ('LlvmType lt) + -- | Singleton constructor for v'BackendType'. + SBackendType :: SBackendType lt -> SType scope ('BackendType lt) {-| The kind of pointer kinds in the AST. Used to annotate pointers with @@ -105,16 +105,16 @@ data SPointerKind pk where -- | Singleton constructor for 'WritePointer'. SWritePointer :: SPointerKind 'WritePointer --- | The subset of LLVM types used internally when emitting LLVM. -newtype LlvmType - -- | An LLVM integer of the given size. A size of 0 is used for @void@. - = LlvmInt Nat +-- | The subset of Backend types used internally when emitting. +newtype BackendType + -- | A backend integer of the given size. + = BackendInt Nat --- | Singleton for t'LlvmType'. Used to witness an LLVM type at runtime. -type SLlvmType :: LlvmType -> Kind.Type -data SLlvmType lt where - -- | Singleton constructor for 'LlvmInt'. - SLlvmInt :: SNat size -> SLlvmType ('LlvmInt size) +-- | Singleton for t'BackendType'. Used to witness a backend type at runtime. +type SBackendType :: BackendType -> Kind.Type +data SBackendType lt where + -- | Singleton constructor for 'BackendInt'. + SBackendInt :: SNat size -> SBackendType ('BackendInt size) -- | The Elemental unit type. Used to encode a @void@ return in the FFI. type UnitType = 'Forall ('TypeVar 'Zero :-> 'TypeVar 'Zero) @@ -159,7 +159,7 @@ type family Increment idx t where Increment idx ('Forall tx) = 'Forall (Increment ('Succ idx) tx) Increment idx ('IOType tx) = 'IOType (Increment idx tx) Increment idx ('PointerType pk tx) = 'PointerType pk (Increment idx tx) - Increment _ ('LlvmType lt) = 'LlvmType lt + Increment _ ('BackendType lt) = 'BackendType lt -- | Singleton version of 'Increment'. sIncrement @@ -176,7 +176,7 @@ sIncrement scope idx = \case SForall tx -> SForall $ sIncrement (SSucc scope) (SSucc idx) tx SIOType tx -> SIOType $ sIncrement scope idx tx SPointerType pk tx -> SPointerType pk $ sIncrement scope idx tx - SLlvmType lt -> SLlvmType lt + SBackendType lt -> SBackendType lt {-| Substitutes a type at the given index. The first type is the substituted @@ -193,7 +193,7 @@ type family Substitute idx tsub t where Substitute idx tsub ('IOType tx) = 'IOType (Substitute idx tsub tx) Substitute idx tsub ('PointerType pk tx) = 'PointerType pk (Substitute idx tsub tx) - Substitute idx tsub ('LlvmType lt) = 'LlvmType lt + Substitute idx tsub ('BackendType lt) = 'BackendType lt -- | Singleton version of 'Substitute'. sSubstitute @@ -217,7 +217,7 @@ sSubstitute scope idx tsub = \case $ sSubstitute (SSucc scope) (SSucc idx) (sIncrement scope SZero tsub) tx SIOType tx -> SIOType $ sSubstitute scope idx tsub tx SPointerType pk tx -> SPointerType pk $ sSubstitute scope idx tsub tx - SLlvmType lt -> SLlvmType lt + SBackendType lt -> SBackendType lt -- | Proof for transposing two increments. incInc @@ -252,7 +252,7 @@ incInc scope idx1 idx2 t lt@Refl = case t of -> withProof (incInc (SSucc scope) (SSucc idx1) (SSucc idx2) tx lt) Refl SIOType tx -> withProof (incInc scope idx1 idx2 tx lt) Refl SPointerType _ tx -> withProof (incInc scope idx1 idx2 tx lt) Refl - SLlvmType _ -> Refl + SBackendType _ -> Refl {-# RULES "Proof/incInc" incInc = \_ _ _ _ -> Unsafe.unsafeCoerce #-} {-# INLINE [1] incInc #-} @@ -286,7 +286,7 @@ incSub scope sidx iidx tsub t slt@Refl ilt = case t of $ withProof (incInc scope iidx SZero tsub Refl) Refl SIOType tx -> withProof (incSub scope sidx iidx tsub tx slt ilt) Refl SPointerType _ tx -> withProof (incSub scope sidx iidx tsub tx slt ilt) Refl - SLlvmType _ -> Refl + SBackendType _ -> Refl {-# RULES "Proof/incSub" incSub = \_ _ _ _ _ _ -> Unsafe.unsafeCoerce #-} {-# INLINE [1] incSub #-} @@ -325,7 +325,7 @@ subInc scope idx1 idx2 tsub t lt1@Refl lt2@Refl = case t of (sIncrement scope SZero tsub) tx lt1 lt2) Refl SIOType tx -> withProof (subInc scope idx1 idx2 tsub tx lt1 lt2) Refl SPointerType _ tx -> withProof (subInc scope idx1 idx2 tsub tx lt1 lt2) Refl - SLlvmType _ -> Refl + SBackendType _ -> Refl {-# RULES "Proof/subInc" subInc = \_ _ _ _ _ _ -> Unsafe.unsafeCoerce #-} {-# INLINE [1] subInc #-} @@ -368,7 +368,7 @@ subSub scope idx1 idx2 tsub1 tsub2 t lt1@Refl lt2@Refl = case t of SIOType tx -> withProof (subSub scope idx1 idx2 tsub1 tsub2 tx lt1 lt2) Refl SPointerType _ tx -> withProof (subSub scope idx1 idx2 tsub1 tsub2 tx lt1 lt2) Refl - SLlvmType _ -> Refl + SBackendType _ -> Refl {-# RULES "Proof/subSub" subSub = \_ _ _ _ _ _ _ -> Unsafe.unsafeCoerce #-} {-# INLINE [1] subSub #-} @@ -391,7 +391,7 @@ subIncElim scope idx tsub t lt = case t of (Proxy @(Increment 'Zero tsub)) tx lt) Refl SIOType tx -> withProof (subIncElim scope idx tsub tx lt) Refl SPointerType _ tx -> withProof (subIncElim scope idx tsub tx lt) Refl - SLlvmType _ -> Refl + SBackendType _ -> Refl {-# RULES "Proof/subIncElim" subIncElim = \_ _ _ _ -> Unsafe.unsafeCoerce #-} {-# INLINE [1] subIncElim #-} diff --git a/src/Language/Elemental/Backend.hs b/src/Language/Elemental/Backend.hs new file mode 100644 index 0000000..03d6896 --- /dev/null +++ b/src/Language/Elemental/Backend.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Language.Elemental.Backend + ( Name(..) + , Named(..) + , Type(..) + , Bit(..) + , Operand(..) + , Instruction(..) + , Body(..) + , Function(..) + , External(..) + , Program(..) + , opType + , instrType + , concatBody + -- * Partial + , Partial(..) + , FoldArrow + , addOperand + -- * Renaming + , renameOp + , renameInstr + , renameBody + -- * Traversals + , opRefs + , instrOps + , instrBodies + , bodyOps + , bodyBoundNames + , bodyFreeRefs + ) where + +import Control.Lens (Traversal', anyOf, (%~)) +import Data.ByteString.Short (ShortByteString) +import Data.DList (DList, snoc, toList) +import Data.Foldable (foldl') +import Data.Kind qualified as Kind +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.String (IsString(fromString)) +import Numeric.Natural (Natural) +import Prettyprinter + ( Doc, Pretty(pretty) + , concatWith, encloseSep, flatAlt, group + , hardline, line, nest, parens, tupled + , (<+>) + ) + +import Language.Elemental.Singleton + +-- | Names for the operand namespace and the function namespace. +data Name + = Name Integer + | ExternalName ShortByteString + | SubName Name Integer + | UnusedName + deriving stock (Eq, Ord, Read, Show) + +instance IsString Name where + fromString = ExternalName . fromString + +instance Pretty Name where + pretty (Name n) = pretty n + pretty (ExternalName str) = pretty $ show str + pretty (SubName name n) = pretty name <> "." <> pretty n + pretty UnusedName = "_" + +data Type = IntType Int | TupleType [Type] + deriving stock (Eq, Read, Show) + +instance Pretty Type where + pretty (IntType size) = "i" <> pretty size + pretty (TupleType ts) = braced $ pretty <$> ts + +data Bit = B0 | B1 + deriving stock (Enum, Eq, Read, Show) + +instance Pretty Bit where + pretty B0 = "0" + pretty B1 = "1" + +data Operand + = Reference Type Name + | Address Type Natural + | Empty + | Constant Bit + -- | Extracts the nth LSB. + | IsolateBit Int Int Operand + -- | Inserts a new MSB. + | InsertBit Int Operand Operand + {-| + The first operand is the condition. The second operand is the result + when the condition's value is @True@. + -} + | Select Operand Operand Operand + | Tuple [Operand] + | GetElement Int Operand + deriving stock (Eq, Read, Show) + +instance Pretty Operand where + -- pretty (Reference t name) = pretty t <+> "%" <> pretty name + -- pretty (Address t addr) = pretty t <+> "@" <> pretty addr + pretty (Reference _ name) = "%" <> pretty name + pretty (Address _ addr) = "@" <> pretty addr + pretty Empty = "[]" + pretty (Constant b) = "#" <> pretty b + pretty (IsolateBit _ idx op) = parens $ pretty op <+> "!!" <+> pretty idx + pretty (InsertBit _ b op) = parens $ pretty b <+> ":" <+> pretty op + pretty (Select op opt opf) = parens $ "if" <+> pretty op + <+> "then" <+> pretty opt <+> "else" <+> pretty opf + pretty (Tuple ops) = braced $ pretty <$> ops + pretty (GetElement idx op) = parens $ pretty op <+> "!" <+> pretty idx + +opType :: Operand -> Type +opType = \case + Reference t _ -> t + Address t _ -> t + Empty -> IntType 0 + Constant _ -> IntType 1 + IsolateBit {} -> IntType 1 + InsertBit size _ _ -> IntType $ succ size + Select _ opt _ -> opType opt + Tuple ops -> TupleType $ opType <$> ops + GetElement idx op -> case opType op of + TupleType ts | length ts > idx -> ts !! idx + _ -> error "illegal GetElement" + +data Instruction + -- | Allows setting a = b. + = Pure Operand + -- | Calls the symbol 'Name' with the given arguments. + | Call Type Name [Operand] + -- | Loads the value of a pointer. + | Load Operand + -- | Stores the second value into the first pointer. + | Store Operand Operand + {-| + Runs the instructions in the first body if the value of the operand is + @True@. Otherwise, it runs the instructions in the second body. + -} + | Branch Operand Body Body + deriving stock (Eq, Read, Show) + +instance Pretty Instruction where + pretty (Pure op) = "Pure" <+> pretty op + pretty (Call _ name args) + = foldl' (<+>) ("Call" <+> pretty name) (pretty <$> args) + pretty (Load op) = "Load" <+> pretty op + pretty (Store op1 op2) = "Store" <+> pretty op1 <+> pretty op2 + pretty (Branch op bt bf) = nest 4 ("If" <+> pretty op >>> pretty bt) + >>> nest 4 ("Else" >>> pretty bf) >>> "End" + +instrType :: Instruction -> Type +instrType = \case + Pure op -> opType op + Call t _ _ -> t + Load ptr -> opType ptr + Store _ _ -> IntType 0 + Branch _ bt _ -> instrType $ bodyTerm bt + +data Partial a where + Partial :: SNat ('Succ n) -> FoldArrow ('Succ n) Operand a -> Partial a + +-- Doesn't check equality of the arrows; for testing. +instance Eq (Partial a) where + Partial a _ == Partial b _ = go a b + where + go :: SNat a -> SNat b -> Bool + go SZero SZero = True + go (SSucc _) SZero = False + go SZero (SSucc _) = False + go (SSucc a') (SSucc b') = go a' b' + +instance Functor Partial where + fmap f' (Partial arity g') = Partial arity $ foldNat f' arity g' + where + foldNat + :: (a -> b) -> SNat n + -> FoldArrow n Operand a -> FoldArrow n Operand b + foldNat f SZero g = f g + foldNat f (SSucc n) g = foldNat f n . g + +instance Pretty (Partial a) where + pretty (Partial n _) = "p" <> pretty (toNatural n) + +type FoldArrow :: Nat -> Kind.Type -> Kind.Type -> Kind.Type +type family FoldArrow n a b where + FoldArrow 'Zero _ b = b + FoldArrow ('Succ n) a b = a -> FoldArrow n a b + +data Named a = Name := a + deriving stock (Eq, Read, Show, Foldable, Functor, Traversable) + +instance Pretty a => Pretty (Named a) where + pretty (name := a) = pretty name <+> "=" <+> pretty a + +data Body = Body + { bodyInstrs :: DList (Named Instruction) + -- | The last instruction in the body. + , bodyTerm :: Instruction + } deriving stock (Eq, Read, Show) + +instance Pretty Body where + pretty b = concatWith (>>>) . toList + $ snoc (pretty <$> bodyInstrs b) (pretty $ bodyTerm b) + +data Function = Function + { functionArgs :: [Named Type] + , functionBody :: Body + } deriving stock (Eq, Read, Show) + +instance Pretty Function where + pretty f = nest 4 ("Function" <+> tupled (pretty <$> functionArgs f) + >>> pretty (functionBody f)) + >>> "End" + +data External = External + { externalArgs :: [Type] + , externalRet :: Type + } deriving stock (Eq, Read, Show) + +instance Pretty External where + pretty (External args ret) = pretty ret <+> tupled (pretty <$> args) + +data Program = Program + { programImports :: [Named External] + , programFunctions :: [Named Function] } + deriving stock (Eq, Read, Show) + +instance Pretty Program where + pretty (Program exts funcs) = concatWith f + [ concatWith f (pretty <$> exts) + , concatWith f (pretty <$> funcs) + ] + where + f a b = a <> line <> line <> b + +addOperand :: Operand -> Partial a -> Either (Partial a) a +addOperand op (Partial (SSucc n) f) = case n of + SZero -> Right $ f op + SSucc _ -> Left $ Partial n $ f op + +concatBody :: Name -> Body -> Body -> Body +concatBody name b1 b2 = Body + { bodyInstrs = snoc (bodyInstrs b1) (name := bodyTerm b1) <> bodyInstrs b2 + , bodyTerm = bodyTerm b2 + } + +opRefs :: Traversal' Operand (Type, Name) +opRefs f op = case op of + Reference t name -> uncurry Reference <$> f (t, name) + Address _ _ -> pure op + Empty -> pure op + Constant _ -> pure op + IsolateBit size idx op' -> IsolateBit size idx <$> opRefs f op' + InsertBit size oph opt -> InsertBit size <$> opRefs f oph <*> opRefs f opt + Select opc opt opf + -> Select <$> opRefs f opc <*> opRefs f opt <*> opRefs f opf + Tuple ops -> Tuple <$> traverse (opRefs f) ops + GetElement idx opt -> GetElement idx <$> opRefs f opt + +renameOp :: M.Map Name Operand -> Operand -> Operand +renameOp re op = case op of + Reference _ name -> fromMaybe op $ re M.!? name + Address _ _ -> op + Empty -> op + Constant _ -> op + IsolateBit size idx op' -> IsolateBit size idx $ renameOp re op' + InsertBit size oph opt -> InsertBit size (renameOp re oph) (renameOp re opt) + Select opc opt opf + -> Select (renameOp re opc) (renameOp re opt) (renameOp re opf) + Tuple ops -> Tuple $ renameOp re <$> ops + GetElement idx opt -> GetElement idx $ renameOp re opt + +renameInstr :: M.Map Name Operand -> Instruction -> Instruction +renameInstr re = instrOps %~ renameOp re + +instrOps :: Traversal' Instruction Operand +instrOps f instr = case instr of + Pure op -> Pure <$> f op + Call t name args -> Call t name <$> traverse f args + Load ptr -> Load <$> f ptr + Store ptr op -> Store <$> f ptr <*> f op + Branch opc bt bf -> Branch <$> f opc <*> bodyOps f bt <*> bodyOps f bf + +instrBodies :: Traversal' Instruction Body +instrBodies f instr = case instr of + Pure _ -> pure instr + Call {} -> pure instr + Load _ -> pure instr + Store _ _ -> pure instr + Branch opc bt bf -> Branch opc <$> f bt <*> f bf + +renameBody :: M.Map Name Operand -> Body -> Body +renameBody re = bodyOps %~ renameOp re + +bodyOps :: Traversal' Body Operand +bodyOps f (Body instrs term) = Body <$> go instrs <*> instrOps f term + where + go = traverse . traverse $ instrOps f + +bodyBoundNames :: Traversal' Body Name +bodyBoundNames f (Body instrs term) = Body <$> go instrs <*> visit term + where + go = traverse $ \(name := instr) -> (:=) <$> f name <*> visit instr + visit = instrBodies . bodyBoundNames $ f + +bodyFreeRefs :: Traversal' Body (Type, Name) +bodyFreeRefs f b@(Body instrs term) = Body <$> go instrs <*> instrNames g term + where + go = traverse . traverse $ instrNames g + g ref + | anyOf bodyBoundNames (== snd ref) b = pure ref + | otherwise = f ref + + instrNames :: Traversal' Instruction (Type, Name) + instrNames = instrOps . opRefs + +(>>>) :: Doc ann -> Doc ann -> Doc ann +a >>> b = a <> flatAlt hardline "; " <> b +infixr 6 >>> + +braced :: [Doc ann] -> Doc ann +braced = group . encloseSep (flatAlt "{ " "{") (flatAlt " }" "}") ", " + diff --git a/src/Language/Elemental/Backend/LLVM.hs b/src/Language/Elemental/Backend/LLVM.hs new file mode 100644 index 0000000..210b3e5 --- /dev/null +++ b/src/Language/Elemental/Backend/LLVM.hs @@ -0,0 +1,234 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Language.Elemental.Backend.LLVM + ( compileProgram + , compileExternal + , compileFunction + , compileBody + , compileInstruction + , compileOperand + , toLlvmName + , toLlvmType + , toLlvmInt + , toLlvmNat + , LlvmOp + , orUndef + , Scope + ) where + +import Control.Carrier.Reader (Reader, asks, local, runReader) +import Data.Foldable (foldrM) +import Data.Functor (void) +import Data.Map qualified as M +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import LLVM.AST qualified as LLVM +import LLVM.AST.CallingConvention qualified as LLVM.CConv +import LLVM.AST.Constant qualified as LLVM.Constant +import LLVM.AST.Linkage qualified as LLVM.Linkage +import LLVM.AST.Type qualified as LLVM.Type +import Math.NumberTheory.Logarithms (naturalLog2) +import Numeric.Natural (Natural) + +import Control.Carrier.IRBuilder +import Control.Carrier.ModuleBuilder +import Language.Elemental.Backend + +type LlvmOp = (LLVM.Type, Maybe LLVM.Operand) + +type Scope = Reader (M.Map Name LLVM.Operand) + +-- | Assumes that functions are defined before the functions that use them. +compileProgram :: Program -> [LLVM.Definition] +compileProgram (Program exts funcs) = run + $ runModuleBuilder (const . pure) emptyModuleBuilder + $ runReader @(M.Map Name LLVM.Operand) M.empty + $ foldr compileExternal (foldr compileFunction (pure ()) funcs) exts + +compileExternal + :: (Has ModuleBuilder sig m, Has Scope sig m) + => Named External -> m r -> m r +compileExternal (name := External targs tret) cont = do + let (_, lname) = toLlvmName name + lopf <- extern lname (toLlvmType <$> targs) (toLlvmType tret) + local (M.insert name lopf) cont + +compileFunction + :: forall sig m r. (Has ModuleBuilder sig m, Has Scope sig m) + => Named Function -> m r -> m r +compileFunction (name := Function args b) cont = do + let tret = toLlvmType $ instrType $ bodyTerm b + (linkage, lname) = toLlvmName name + lopf <- function lname (toLlvmType . namedValue <$> args) tret linkage + $ \lops -> do + foldr bindOp (compileBody b >>= mkRet) $ zip args lops + void block + local (M.insert name lopf) cont + where + namedValue :: Named a -> a + namedValue (_ := a) = a + + bindOp :: (Named Type, LLVM.Operand) -> IRBuilderC m r' -> IRBuilderC m r' + bindOp (name' := _, lop) = local (M.insert name' lop) + + mkRet :: LlvmOp -> IRBuilderC m () + mkRet = emitTerm . ($ []) . LLVM.Ret . snd + +compileBody + :: forall sig m. (Has IRBuilder sig m, Has Scope sig m) => Body -> m LlvmOp +compileBody (Body instrs term) = foldr go (compileInstruction term) instrs + where + go :: Named Instruction -> m r -> m r + go (name := instr) cont = do + lop <- compileInstruction instr + case name of + UnusedName -> cont + _ -> local (M.insert name $ orUndef lop) cont + +compileInstruction + :: (Has IRBuilder sig m, Has Scope sig m) => Instruction -> m LlvmOp +compileInstruction = \case + Pure op -> compileOperand op + Call t name args -> do + lopf <- fromMaybe (error $ "function not in scope: " <> show name) + <$> asks (M.!? name) + largs <- traverse ((mkParam . orUndef <$>) . compileOperand) args + let call = LLVM.Call Nothing LLVM.CConv.C [] (Right lopf) largs [] [] + ltret = toLlvmType t + (,) ltret <$> case t of + IntType 0 -> Nothing <$ emitInstrVoid call + _ -> Just <$> emitInstr ltret call + Load ptr -> do + (lt, mlptr) <- compileOperand ptr + let lptr = fromMaybe (undef $ LLVM.Type.ptr lt) mlptr + ((,) lt . Just <$>) $ emitInstr lt $ LLVM.Load True lptr Nothing 1 [] + Store ptr op -> do + (ltp, mlptr) <- compileOperand ptr + (lt, mlop) <- compileOperand op + let lptr = fromMaybe (undef $ LLVM.Type.ptr ltp) mlptr + lop = fromMaybe (undef lt) mlop + emitInstrVoid $ LLVM.Store True lptr lop Nothing 1 [] + pure (LLVM.VoidType, Nothing) + Branch opc bt bf -> do + lopc <- orUndef <$> compileOperand opc + lbt <- fresh + lbf <- fresh + lbr <- fresh + emitTerm $ LLVM.CondBr lopc lbt lbf [] + emitBlockStart lbt + (ltt, mlopt) <- compileBody bt + lbt' <- currentBlock + emitTerm $ LLVM.Br lbr [] + emitBlockStart lbf + (ltf, mlopf) <- compileBody bf + lbf' <- currentBlock + emitTerm $ LLVM.Br lbr [] + emitBlockStart lbr + case (mlopt, mlopf) of + (Nothing, Nothing) -> pure (ltt, Nothing) + _ -> do + let lopt = orUndef (ltt, mlopt) + lopf = orUndef (ltf, mlopf) + ((,) ltt . Just <$>) $ emitInstr ltt + $ LLVM.Phi ltt [(lopt, lbt'), (lopf, lbf')] [] + where + mkParam a = (a, []) + +compileOperand :: (Has IRBuilder sig m, Has Scope sig m) => Operand -> m LlvmOp +compileOperand = skipVoid $ \case + Reference t name -> asks $ (,) (toLlvmType t) . (M.!? name) + Address t addr -> pure $ (,) (toLlvmType t) $ Just $ LLVM.ConstantOperand + $ LLVM.Constant.IntToPtr (toLlvmNat addr) $ LLVM.Type.ptr $ toLlvmType t + Empty -> pure (LLVM.VoidType, Nothing) + Constant bit -> pure $ (,) LLVM.Type.i1 $ Just + $ LLVM.ConstantOperand $ LLVM.Constant.Int 1 $ toInteger $ fromEnum bit + IsolateBit size idx op -> do + lop <- orUndef <$> compileOperand op + lops <- emitInstr (LLVM.IntegerType $ succ $ fromIntegral size) + $ LLVM.LShr False lop (toLlvmInt size $ toInteger idx) [] + ((,) LLVM.Type.i1 . Just <$>) $ emitInstr LLVM.Type.i1 + $ LLVM.Trunc lops LLVM.Type.i1 [] + InsertBit size op1 op2 -> case size of + 0 -> compileOperand op1 + _ -> do + lop1 <- orUndef <$> compileOperand op1 + lop2 <- orUndef <$> compileOperand op2 + let lt = LLVM.IntegerType $ succ $ fromIntegral size + sh = toInteger size + lopz1 <- emitInstr lt $ LLVM.ZExt lop1 lt [] + lopz2 <- emitInstr lt $ LLVM.ZExt lop2 lt [] + lops1 <- emitInstr lt + $ LLVM.Shl False True lopz1 (toLlvmInt (succ size) sh) [] + ((,) lt . Just <$>) $ emitInstr lt $ LLVM.Or lops1 lopz2 [] + Select opc opt opf -> do + (ltc, mlopc) <- compileOperand opc + (ltt, mlopt) <- compileOperand opt + (ltf, mlopf) <- compileOperand opf + let lopc = fromMaybe (undef ltc) mlopc + lopt = fromMaybe (undef ltt) mlopt + lopf = fromMaybe (undef ltf) mlopf + ((,) ltt . Just <$>) $ emitInstr ltt $ LLVM.Select lopc lopt lopf [] + Tuple ops -> do + lops <- traverse (fmap orUndef . compileOperand) ops + let lt = toLlvmType $ TupleType $ opType <$> ops + lopz = LLVM.ConstantOperand $ LLVM.Constant.AggregateZero lt + ((,) lt . Just <$>) $ foldrM (insertStruct lt) lopz $ zip [0..] lops + opSelf@(GetElement idx op) -> do + lop <- orUndef <$> compileOperand op + let lt = toLlvmType $ opType opSelf + ((,) lt . Just <$>) $ emitInstr lt + $ LLVM.ExtractValue lop [fromIntegral idx] [] + where + insertStruct + :: Has IRBuilder sig m + => LLVM.Type -> (Int, LLVM.Operand) -> LLVM.Operand -> m LLVM.Operand + insertStruct lt (idx, lop1) lops = emitInstr lt + $ LLVM.InsertValue lops lop1 [fromIntegral idx] [] + + skipVoid + :: Has IRBuilder sig m => (Operand -> m LlvmOp) -> Operand -> m LlvmOp + skipVoid cont op = case opType op of + IntType 0 -> pure (LLVM.VoidType, Nothing) + _ -> cont op + +undef :: LLVM.Type -> LLVM.Operand +undef = LLVM.ConstantOperand . LLVM.Constant.Undef + +orUndef :: LlvmOp -> LLVM.Operand +orUndef (lt, mlop) = fromMaybe (undef lt) mlop + +toLlvmName :: Name -> (LLVM.Linkage.Linkage, LLVM.Name) +toLlvmName name = case name of + Name {} -> (LLVM.Linkage.Private, LLVM.Name $ go name) + ExternalName {} -> (LLVM.Linkage.External, LLVM.Name $ go name) + SubName {} -> (LLVM.Linkage.Private, LLVM.Name $ go name) + UnusedName {} -> (LLVM.Linkage.Private, LLVM.Name $ go name) + where + go = \case + Name idx -> fromString $ show idx + ExternalName name' -> name' + SubName name' idx -> go name' <> fromString ('.' : show idx) + UnusedName -> "_" + +toLlvmType :: Type -> LLVM.Type +toLlvmType = \case + IntType 0 -> LLVM.VoidType + IntType size -> LLVM.IntegerType $ fromIntegral size + TupleType ts -> LLVM.StructureType False $ toLlvmType <$> ts + +toLlvmInt :: Integral n => n -> Integer -> LLVM.Operand +toLlvmInt size n + = LLVM.ConstantOperand $ LLVM.Constant.Int (fromIntegral size) n + +toLlvmNat :: Natural -> LLVM.Constant.Constant +toLlvmNat n = LLVM.Constant.Int size $ toInteger n + where + size :: Num n => n + size + | n == 0 = 1 + | otherwise = fromIntegral $ naturalLog2 n + 1 + diff --git a/src/Language/Elemental/Emit.hs b/src/Language/Elemental/Emit.hs index 9996e68..2527cb9 100644 --- a/src/Language/Elemental/Emit.hs +++ b/src/Language/Elemental/Emit.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -9,598 +8,262 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} --- | Functions to convert an Elemental program into an LLVM module. +-- | Functions to convert an Elemental program into an interaction net. module Language.Elemental.Emit ( emitProgram , emitDeclScope , emitDecl , emitExpr - , emitExprIO - , emitExprOp - , foldArrow - , foldForall - , foldIO - , foldPointer - , llvmType - , llvmForeignName - , llvmAddress + , backendType + , backendForeignName ) where -import Control.Monad (void) +import Control.Algebra ((:+:)) +import Control.Carrier.State.Church (State, get, put, runState) +import Control.Monad.Trans.Class (lift) +import Data.DList (DList, toList) +import Data.Functor.Const (Const(..), getConst) import Data.Text.Short (toShortByteString) -import Data.Type.Equality ((:~:)(Refl)) -import Data.Void (absurd) -import LLVM.AST qualified as LLVM -import LLVM.AST.CallingConvention qualified as LLVM.CallConv -import LLVM.AST.Constant qualified as LLVM.Constant -import LLVM.AST.Type qualified as LLVM.Type -import Math.NumberTheory.Logarithms (naturalLog2) import Control.Carrier.ModuleBuilder -import Control.Effect.IRBuilder import Language.Elemental.AST.Decl import Language.Elemental.AST.Expr import Language.Elemental.AST.Program import Language.Elemental.AST.Type +import Language.Elemental.Backend qualified as Backend +import Language.Elemental.InteractionNet import Language.Elemental.Primitive import Language.Elemental.Singleton - --- | Emits a program as a list of LLVM definitions. -emitProgram :: Program -> [LLVM.Definition] -emitProgram (Program decls) - = runModuleBuilder const emptyModuleBuilder $ emitDeclScope decls +-- | Emits a program as an interaction net. +emitProgram + :: HasRewriter sig m => Program -> m [Backend.Named Backend.External] +emitProgram (Program decls) = toList <$> emitDeclScope SNil SNil decls -- | Emits a list of declarations. -emitDeclScope :: Has ModuleBuilder sig m => DeclScope '[] rest -> m () -emitDeclScope = \case - DeclNil -> pure () - DeclCons decl decls -> do - expr <- emitDecl decl - case declType SNil decl of - SNothing -> emitDeclScope decls - SJust t -> emitDeclScope - $ substituteDeclScope (t :^ SNil) SZero expr decls +emitDeclScope + :: (HasRewriter sig m) + => SList (SType 'Zero) scope -> SList (Const (Ref -> m ())) scope + -> DeclScope scope rest -> m (DList (Backend.Named Backend.External)) +emitDeclScope scopeTypes scope = \case + DeclNil -> pure mempty + DeclCons decl decls -> case declType scopeTypes decl of + SNothing -> do + exts <- emitDecl scopeTypes scope () decl + (exts <>) <$> emitDeclScope scopeTypes scope decls + SJust t -> do + rn0 <- newNode $ const $ AppNode () () () + rn1 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn0 0) (Ref rn1 0) + propagate2 (Ref rn0 2) (Ref rn1 2) DeadNode + exts <- emitDecl scopeTypes scope (Const $ Ref rn0 1) decl + Ref rn1 1 >=^ scope + $ \scope' -> (exts <>) + <$> emitDeclScope (t :^ scopeTypes) scope' decls {-| Emits a declaration, returning the expression to add to the scope if the declaration adds anything to the scope. -} emitDecl - :: Has ModuleBuilder sig m - => Decl '[] mt -> m (FoldMaybe () (Expr 'Zero '[]) mt) -emitDecl = \case - Binding expr -> pure expr + :: (HasRewriter sig m) + => SList (SType 'Zero) scope -> SList (Const (Ref -> m ())) scope + -> FoldMaybe () (Const Ref) mt -> Decl scope mt + -> m (DList (Backend.Named Backend.External)) +emitDecl scopeTypes scope rr = \case + Binding expr -> mempty <$ emitExpr scope (getConst rr) expr ForeignImport fname t -> do let ltargs = sForeignArgs t - ltargs' = llvmArgs ltargs ltret = sForeignRet t - ltret' = llvmType ltret - op <- extern (llvmForeignName fname) ltargs' ltret' - pure $ wrapImport SZero SNil t $ Call (Right op) [] ltargs ltret + name = backendForeignName fname + emitExpr scope (getConst rr) + $ wrapImport SZero scopeTypes t $ Call name ltargs ltret + pure $ pure $ name + Backend.:= Backend.External (backendArgs ltargs) (backendType ltret) ForeignExport fname expr -> do - let t = exprType SZero SNil expr + let t = exprType SZero scopeTypes expr ltargs = sForeignArgs t - ltargs' = llvmArgs ltargs ltret = sForeignRet t - ltret' = llvmType ltret - export ops = applyArgs ltret ltargs ops - $ wrapExport SZero SNil t expr - _ <- function (llvmForeignName fname) ltargs' ltret' $ emitExpr . export - pure () - ForeignPrimitive pfin -> pure $ primitiveExprs !!^ pfin - ForeignAddress addr pk t -> pure $ Addr addr pk t + freshNums <- traverseSList newNodeIndex ltargs + let names = Backend.Name . fromIntegral <$> freshNums + ops = zipWith Backend.Reference (backendArgs ltargs) names + args = zipWith (Backend.:=) names (backendArgs ltargs) + rn1 <- newNode $ const $ RootNode (backendForeignName fname) args () + emitExpr scope (Ref rn1 0) $ applyArgs ltret ltargs ops + $ wrapExport SZero scopeTypes t expr + pure mempty + ForeignPrimitive pfin + -> (mempty <$) $ emitExpr scope (getConst rr) $ primitiveExprs !!^ pfin + ForeignAddress addr pk (t :: SType 'Zero t) -> let + lt :: SType 'Zero ('BackendType (Marshall t)) + lt = SBackendType $ sMarshall t + baddr = Backend.Address (backendType $ sMarshall t) $ getAddress addr + li0 = SBackendInt SZero + i0 = SBackendType li0 + in case pk of + SReadPointer -> (mempty <$) $ emitExpr scope (getConst rr) $ BindIO + :@ lt :$ BackendIO (sMarshall t) + (Backend.Body mempty $ Backend.Load baddr) + :@ t :$ Lam lt (PureIO :@ t + :$ marshallIn SZero (lt :^ scopeTypes) t (Var SZero)) + SWritePointer -> (mempty <$) $ emitExpr scope (getConst rr) + $ Lam t $ BindIO + :@ i0 :$ (BackendPIO (sMarshall t) li0 (Backend.Store baddr) + :$ marshallOut SZero (t :^ scopeTypes) t (Var SZero)) + :@ SUnitType :$ Lam i0 (PureIO :@ SUnitType + :$ marshallIn SZero (i0 :^ t :^ scopeTypes) SUnitType + (Var SZero)) where - llvmArgs :: SList SLlvmType lts -> [LLVM.Type] - llvmArgs SNil = [] - llvmArgs (lt :^ lts) = llvmType lt : llvmArgs lts + traverseSList :: Applicative f => f a -> SList sing as -> f [a] + traverseSList _ SNil = pure [] + traverseSList f (_ :^ xs) = (:) <$> f <*> traverseSList f xs + backendArgs :: SList SBackendType lts -> [Backend.Type] + backendArgs SNil = [] + backendArgs (lt :^ lts) = backendType lt : backendArgs lts + applyArgs :: AllIsOpType ltargs ~ 'True - => proxy ltret -> SList SLlvmType ltargs -> [LLVM.Operand] - -> Expr 'Zero '[] (BuildForeignType ltargs ltret) - -> Expr 'Zero '[] ('IOType ('LlvmType ltret)) + => proxy ltret -> SList SBackendType ltargs -> [Backend.Operand] + -> Expr 'Zero scope (BuildForeignType ltargs ltret) + -> Expr 'Zero scope ('IOType ('BackendType ltret)) applyArgs _ SNil [] expr = expr applyArgs t (ltarg :^ ltargs) (op : ops) expr = withAllIsOpTypeProof ltarg ltargs $ applyArgs t ltargs ops - $ expr :$ LlvmOperand ltarg op + $ expr :$ BackendOperand ltarg op applyArgs _ SNil ops _ = error $ "emitDecl: " <> show (length ops) <> " excess operands" applyArgs _ ltargs [] _ = error $ "emitDecl: " <> show (toNatural $ sLength ltargs) <> " missing operands" --- | Emits an expression. This emits a @ret@ instruction. emitExpr - :: Has IRBuilder sig m => Expr 'Zero '[] ('IOType ('LlvmType lt)) -> m () -emitExpr expr = do - let SIOType (SLlvmType lt) = exprType SZero SNil expr - mop <- toMaybeOp lt <$> emitExprIO expr - emitTerm $ LLVM.Ret mop [] - void block + :: forall tscope scope tx sig m. HasRewriter sig m + => SList (Const (Ref -> m ())) scope -> Ref -> Expr tscope scope tx -> m () +emitExpr scope rr = \case + Var vidx -> mkBox vidx >>= getConst (scope !!^ vidx) + App ef ex -> do + rn1 <- newNode $ const $ AppNode () () () + emitExpr scope (Ref rn1 0) ef + emitExpr scope (Ref rn1 1) ex + linkNodes rr $ Ref rn1 2 + TypeApp ef _ -> emitExpr scope rr ef + Lam _ ey -> do + rn1 <- newNode $ const $ LamNode () () () + Ref rn1 1 >=^ scope $ \scope' -> emitExpr scope' (Ref rn1 2) ey + linkNodes rr $ Ref rn1 0 + TypeLam ex -> emitExpr (coerceScope scope) rr ex + Addr addr _ tx -> do + rn1 <- newNode $ const $ OperandNode (Backend.Address + (backendType $ sMarshall tx) $ getAddress addr) () + linkNodes rr $ Ref rn1 0 + BackendOperand _ op -> do + rn1 <- newNode $ const $ OperandNode op () + linkNodes rr $ Ref rn1 0 + BackendIO _ body -> do + rn1 <- newNode $ const $ IONode body () + linkNodes rr $ Ref rn1 0 + BackendPIO _ _ pio + -> mkLambda rr $ IOPNode (Backend.Partial (SSucc SZero) pio) + PureIO -> mkLambda rr Pure0Node + BindIO -> mkLambda rr Bind0Node + LoadPointer -> do + rn1 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn1 1) (Ref rn1 2) + linkNodes rr $ Ref rn1 0 + StorePointer -> do + rn1 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn1 1) (Ref rn1 2) + linkNodes rr $ Ref rn1 0 + Call name SNil tret -> do + let body = Backend.Body + { Backend.bodyInstrs = mempty + , Backend.bodyTerm = Backend.Call (backendType tret) name [] + } + propagate1 rr $ IONode body + Call name ltargs@(_ :^ _) tret -> do + let callp = Backend.Partial len $ withVarargs len + $ Backend.Call (backendType tret) name + len = sLength ltargs + mkLambda rr $ IOPNode callp + IsolateBit bidx ssize -> do + let opp = Backend.Partial (SSucc SZero) $ mkIsolateBit size bidx' + size = fromIntegral $ toNatural ssize + bidx' = fromIntegral $ toNatural bidx + mkLambda rr $ OperandPNode opp + InsertBit ssize -> do + let opp = Backend.Partial (SSucc $ SSucc SZero) $ Backend.InsertBit size + size = fromIntegral $ toNatural ssize + mkLambda rr $ OperandPNode opp + TestBit -> mkLambda rr $ Branch0Node 0 where - toMaybeOp :: SLlvmType lt -> LlvmOperandType lt -> Maybe LLVM.Operand - toMaybeOp lt op = case sIsOpType lt of - SFalse -> Nothing - STrue -> Just op + coerceScope :: SList (Const a) as -> SList (Const a) (IncrementAll 'Zero as) + coerceScope SNil = SNil + coerceScope (Const a :^ as) = Const a :^ coerceScope as -{-| - Emits an expression. Unlike 'emitExpr', this does not emit a @ret@ - instruction but instead returns the final operand for the caller to use. --} -emitExprIO - :: forall lt sig m. Has IRBuilder sig m - => Expr 'Zero '[] ('IOType ('LlvmType lt)) -> m (LlvmOperandType lt) -emitExprIO = \case - Var vidx -> absurd $ zeroNoLT vidx Refl - App ef ex -> foldArrow - (\tx -> emitExprIO . substituteExpr SZero (tx :^ SNil) SZero ex) - (\Refl -> emitExprOp ex) - (\_ -> \case {}) - (\Refl Refl tx ey ty -> foldIO - (\Refl lt -> do - op <- emitExprIO ey - emitExprIO $ ex :$ LlvmOperand lt op) - (\ez -> emitExprIO $ ex :$ ez) - (\op et ef' -> withProof (subIncElim SZero SZero ty tx Refl) - $ emitCondBr op - (BindIO :@ tx :$ et :@ ty :$ ex) - (BindIO :@ tx :$ ef' :@ ty :$ ex)) - ey) - (\Refl Refl _ -> foldPointer - (\tx pop -> do - let lt = sMarshall tx - op <- emitInstr (llvmType lt) $ LLVM.Load True pop Nothing 1 [] - emitExprOp $ marshallIn SZero SNil tx $ LlvmOperand lt op) - ex) - (\_ -> \case {}) - (\case {}) - (\Refl Refl fop aops (ltarg :^ SNil) ltret -> do - aop <- withAllIsOpTypeProof ltarg SNil $ emitExprOp ex - emitCall fop (aop : aops) ltret) - (\_ -> \case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\case {}) - (\Refl op ey -> emitCondBr op ey ex) - (\op ey ez -> emitCondBr op (ey :$ ex) (ez :$ ex)) - ef - TypeApp ef tx -> foldForall - (emitExprIO . substituteExprType SZero SNil SZero tx) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\op ey ez -> emitCondBr op (ey :@ tx) (ez :@ tx)) - ef - LlvmIO _ mop -> mop - Call fop aops SNil ltret -> emitCall fop aops ltret - where - emitCall - :: LLVM.CallableOperand -> [LLVM.Operand] - -> SLlvmType ltret -> m (LlvmOperandType ltret) - emitCall fop aops ltret = case sIsOpType ltret of - SFalse -> emitInstrVoid instr - STrue -> emitInstr (llvmType ltret) instr - where - instr = LLVM.Call Nothing LLVM.CallConv.C [] fop - ((, []) <$> reverse aops) [] [] + withVarargs :: SNat n -> ([a] -> b) -> Backend.FoldArrow n a b + withVarargs SZero f = f [] + withVarargs (SSucc n) f = \x -> withVarargs n $ f . (x :) - emitCondBr - :: LLVM.Operand - -> Expr 'Zero '[] ('IOType ('LlvmType lt)) - -> Expr 'Zero '[] ('IOType ('LlvmType lt)) - -> m (LlvmOperandType lt) - emitCondBr opc et ef = do - bt <- fresh - bf <- fresh - br <- fresh - emitTerm $ LLVM.CondBr opc bt bf [] - emitBlockStart bt - opt <- emitExprIO et - bt' <- currentBlock - emitTerm $ LLVM.Br br [] - emitBlockStart bf - opf <- emitExprIO ef - bf' <- currentBlock - emitTerm $ LLVM.Br br [] - emitBlockStart br - case sIsOpType lt of - SFalse -> pure () - STrue -> emitInstr (llvmType lt) - $ LLVM.Phi (llvmType lt) [(opt, bt'), (opf, bf')] [] - where - SIOType (SLlvmType lt) = exprType SZero SNil et + mkBox :: SNat n -> m Ref + mkBox SZero = pure rr + mkBox (SSucc n) = do + r1 <- mkBox n + rn2 <- newNode $ const $ BoxNode 0 () () + linkNodes r1 $ Ref rn2 1 + pure $ Ref rn2 0 -{-| - Emits a pure LLVM operand. + mkIsolateBit :: Int -> Int -> Backend.Operand -> Backend.Operand + mkIsolateBit size bidx (Backend.InsertBit _ oph opt) + | bidx == 0 = oph + | otherwise = mkIsolateBit size (pred bidx) opt + mkIsolateBit size bidx op = Backend.IsolateBit size bidx op - This still needs an 'IRBuilder' effect because it may need to emit - instructions for operand conversion. All instructions emitted by this - function do not have any side effects; they may be eliminated by the LLVM - optimiser if their result is unused. --} -emitExprOp - :: forall lt sig m. Has IRBuilder sig m - => Expr 'Zero '[] ('LlvmType lt) -> m (LlvmOperandType lt) -emitExprOp = \case - Var vidx -> absurd $ zeroNoLT vidx Refl - App ef ex -> foldArrow - (\tx -> emitExprOp . substituteExpr SZero (tx :^ SNil) SZero ex) - (\case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\case {}) - (\Refl Refl _ _ (_ :^ ltargs) _ -> case ltargs of {}) - (\Refl Refl bidx size -> do - let SLlvmType lt = exprType SZero SNil ex - li1 = llvmType $ SLlvmInt $ SSucc SZero - op <- withProof (ltRightPredSucc bidx size Refl) - $ emitExprOp ex - shifted <- emitInstr (llvmType lt) $ LLVM.LShr False op - (LLVM.ConstantOperand $ LLVM.Constant.Int - (fromIntegral $ toNatural size) - (fromIntegral $ toNatural bidx)) [] - emitInstr li1 $ LLVM.Trunc shifted li1 []) - (\_ -> \case {}) - (\Refl Refl size bop -> case sCmpNat size SZero of - SLT -> absurd $ zeroNoLT size Refl - SEQ -> pure bop - SGT -> do - iop <- emitExprOp ex - let lt = SLlvmInt $ SSucc size - ft = llvmType lt - usize :: Integral n => n - usize = fromIntegral $ toNatural size - bext <- emitInstr ft $ LLVM.ZExt bop ft [] - iext <- emitInstr ft $ LLVM.ZExt iop ft [] - bsh <- emitInstr ft $ LLVM.Shl False True bext - (LLVM.ConstantOperand $ LLVM.Constant.Int - (usize + 1) usize) [] - emitInstr ft $ LLVM.Or bsh iext []) - (\case {}) - (\Refl op ey -> emitSelect op ey ex) - (\op ey ez -> emitSelect op (ey :$ ex) (ez :$ ex)) - ef - TypeApp ef tx -> foldForall - (emitExprOp . substituteExprType SZero SNil SZero tx) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\op ey ez -> emitSelect op (ey :@ tx) (ez :@ tx)) - ef - LlvmOperand _ op -> pure op - Call _ _ ltargs _ -> case ltargs of {} +(>=^) + :: HasRewriter sig m + => Ref -> SList (Const (Ref -> m ())) scope + -> (forall n. Algebra (State (Ref, Maybe Ref) :+: sig) n + => SList (Const (Ref -> n ())) (tx ': scope) -> n r) + -> m r +(r0 >=^ sc) f = runState @(Ref, Maybe Ref) finish (r0, Nothing) $ f + $ Const dup :^ sMap (Const . (.) lift . getConst) sc where - emitSelect - :: LLVM.Operand - -> Expr 'Zero '[] ('LlvmType lt) -> Expr 'Zero '[] ('LlvmType lt) - -> m (LlvmOperandType lt) - emitSelect opc et ef = case sIsOpType lt of - SFalse -> pure () - STrue -> do - opt <- emitExprOp et - opf <- emitExprOp ef - emitInstr (llvmType lt) $ LLVM.Select opc opt opf [] - where - SLlvmType lt = exprType SZero SNil et - --- | Folds an arrow using the given continuations for each possible value. -foldArrow - :: forall ta tb sig r m. Has IRBuilder sig m - => (SType 'Zero ta -> Expr 'Zero '[ta] tb -> m r) - -- ^ Lam - -> (tb :~: 'IOType ta -> m r) - -- ^ PureIO :@ ta - -> (forall tx. ta :~: 'IOType tx -> tb :~: 'Forall ((Increment 'Zero tx - :-> 'IOType ('TypeVar 'Zero)) :-> 'IOType ('TypeVar 'Zero)) - -> SType 'Zero tx -> m r) - -- ^ BindIO :@ _ - -> (forall tx ty. ta :~: 'Arrow tx ('IOType ty) -> tb :~: 'IOType ty - -> SType 'Zero tx -> Expr 'Zero '[] ('IOType tx) - -> SType 'Zero ty -> m r) - -- ^ BindIO :@ _ :$ _ :@ _ - -> (forall tx. ta :~: 'PointerType 'ReadPointer tx -> tb :~: 'IOType tx - -> SType 'Zero tx -> m r) - -- ^ LoadPointer :@ _ - -> (forall tx. ta :~: 'PointerType 'WritePointer tx - -> tb :~: (tx :-> 'IOType UnitType) -> SType 'Zero tx -> m r) - -- ^ StorePointer :@ _ - -> (tb :~: 'IOType UnitType - -> Expr 'Zero '[] ('PointerType 'WritePointer ta) -> m r) - -- ^ StorePointer :@ ta :$ _ - -> (forall ltarg ltargs ltret. AllIsOpType (ltarg ': ltargs) ~ 'True - => ta :~: 'LlvmType ltarg - -> tb :~: BuildForeignType ltargs ltret - -> LLVM.CallableOperand -> [LLVM.Operand] - -> SList SLlvmType (ltarg ': ltargs) -> SLlvmType ltret -> m r) - -- ^ Call _ _ _ _ - -> (forall bidx size. CmpNat bidx size ~ 'LT - => ta :~: 'LlvmType ('LlvmInt size) - -> tb :~: 'LlvmType ('LlvmInt ('Succ 'Zero)) - -> SNat bidx -> SNat size -> m r) - -- ^ IsolateBit _ - -> (forall size. ta :~: 'LlvmType ('LlvmInt ('Succ 'Zero)) - -> tb :~: ('LlvmType ('LlvmInt size) - :-> 'LlvmType ('LlvmInt ('Succ size))) - -> SNat size -> m r) - -- ^ InsertBit _ - -> (forall size. ta :~: 'LlvmType ('LlvmInt size) - -> tb :~: 'LlvmType ('LlvmInt ('Succ size)) - -> SNat size -> LLVM.Operand -> m r) - -- ^ InsertBit _ :$ _ - -> (tb :~: 'Arrow ta ta -> LLVM.Operand -> m r) - -- ^ TestBit _ :@ ta - -> (tb :~: ta -> LLVM.Operand -> Expr 'Zero '[] ta -> m r) - -- ^ TestBit _ :@ ta :$ _ - -> (LLVM.Operand -> Expr 'Zero '[] (ta :-> tb) - -> Expr 'Zero '[] (ta :-> tb) -> m r) - -- ^ TestBit _ :@ ta :-> tb :$ _ :$ _ - -> Expr 'Zero '[] (ta :-> tb) -> m r -foldArrow lam pureIO1 bindIO1 bindIO3 loadPointer1 storePointer1 storePointer2 - call isolateBit insertBit insertBit1 testBit1 testBit2 testBit3 = \case - Var vidx -> absurd $ zeroNoLT vidx Refl - App ef ex -> foldArrow - (\tx -> foldArrow lam pureIO1 bindIO1 bindIO3 loadPointer1 storePointer1 - storePointer2 call isolateBit insertBit insertBit1 testBit1 - testBit2 testBit3 - . substituteExpr SZero (tx :^ SNil) SZero ex) - (\case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\Refl Refl _ -> storePointer2 Refl ex) - (\case {}) - (\Refl Refl fop aops (ltarg :^ ltargs) ltret -> case ltargs of - _ :^ _ -> withAllIsOpTypeProof ltarg ltargs $ do - aop <- emitExprOp ex - call Refl Refl fop (aop : aops) ltargs ltret) - (\_ -> \case {}) - (\Refl Refl size -> emitExprOp ex >>= insertBit1 Refl Refl size) - (\_ -> \case {}) - (\Refl op -> testBit2 Refl op ex) - (\Refl op ey -> testBit3 op ey ex) - (\op ey ez -> testBit3 op (ey :$ ex) (ez :$ ex)) - ef - TypeApp ef tx -> foldForall - (foldArrow lam pureIO1 bindIO1 bindIO3 loadPointer1 storePointer1 - storePointer2 call isolateBit insertBit insertBit1 testBit1 - testBit2 testBit3 - . substituteExprType SZero SNil SZero tx) - (\Refl -> pureIO1 Refl) - (\Refl -> bindIO1 Refl Refl tx) - (\Refl ty ex -> withProof (subIncElim SZero SZero tx ty Refl) - $ bindIO3 Refl Refl ty ex tx) - (\Refl -> loadPointer1 Refl Refl tx) - (\Refl -> storePointer1 Refl Refl tx) - (\Refl -> testBit1 Refl) - (\op ey ez -> testBit3 op (ey :@ tx) (ez :@ tx)) - ef - Lam tx ex -> lam tx ex - Call fop aops ltargs@(_ :^ _) ltret -> call Refl Refl fop aops ltargs ltret - IsolateBit bidx size -> isolateBit Refl Refl bidx size - InsertBit size -> insertBit Refl Refl size + sMap :: (forall a. f a -> g a) -> SList f as -> SList g as + sMap _ SNil = SNil + sMap nt (a :^ as) = nt a :^ sMap nt as --- | Folds a forall using the given continuations for each possible value. -foldForall - :: forall t sig r m. Has IRBuilder sig m - => (Expr ('Succ 'Zero) '[] t -> m r) - -- ^ TypeLam - -> (t :~: ('TypeVar 'Zero :-> 'IOType ('TypeVar 'Zero)) -> m r) - -- ^ PureIO - -> (t :~: ('IOType ('TypeVar 'Zero) :-> 'Forall (('TypeVar ('Succ 'Zero) - :-> 'IOType ('TypeVar 'Zero)) :-> 'IOType ('TypeVar 'Zero))) -> m r) - -- ^ BindIO - -> (forall tx. t :~: ((Increment 'Zero tx :-> 'IOType ('TypeVar 'Zero)) - :-> 'IOType ('TypeVar 'Zero)) - -> SType 'Zero tx -> Expr 'Zero '[] ('IOType tx) -> m r) - -- ^ BindIO :@ _ :$ _ - -> (t :~: ('PointerType 'ReadPointer ('TypeVar 'Zero) - :-> 'IOType ('TypeVar 'Zero)) -> m r) - -- ^ LoadPointer - -> (t :~: ('PointerType 'WritePointer ('TypeVar 'Zero) :-> 'TypeVar 'Zero - :-> 'IOType UnitType) -> m r) - -- ^ StorePointer - -> (t :~: ('TypeVar 'Zero :-> 'TypeVar 'Zero :-> 'TypeVar 'Zero) - -> LLVM.Operand -> m r) - -- ^ TestBit - -> (LLVM.Operand -> Expr 'Zero '[] ('Forall t) - -> Expr 'Zero '[] ('Forall t) -> m r) - -- ^ TestBit _ :@ Forall t :$ _ :$ _ - -> Expr 'Zero '[] ('Forall t) -> m r -foldForall typeLam pureIO bindIO bindIO2 loadPointer storePointer testBit - testBit3 = \case - Var vidx -> absurd $ zeroNoLT vidx Refl - App ef ex -> foldArrow - (\tx -> foldForall typeLam pureIO bindIO bindIO2 loadPointer - storePointer testBit testBit3 - . substituteExpr SZero (tx :^ SNil) SZero ex) - (\case {}) - (\Refl Refl tx -> bindIO2 Refl tx ex) - (\_ -> \case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\case {}) - (\Refl Refl _ _ (_ :^ ltargs) _ -> case ltargs of {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\case {}) - (\Refl op ey -> testBit3 op ey ex) - (\op ey ez -> testBit3 op (ey :$ ex) (ez :$ ex)) - ef - TypeApp ef tx -> foldForall - (foldForall typeLam pureIO bindIO bindIO2 loadPointer storePointer - testBit testBit3 . substituteExprType SZero SNil SZero tx) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\op ey ez -> testBit3 op (ey :@ tx) (ez :@ tx)) - ef - TypeLam ex -> typeLam ex - PureIO -> pureIO Refl - BindIO -> bindIO Refl - LoadPointer -> loadPointer Refl - StorePointer -> storePointer Refl - Call _ _ ltargs _ -> case ltargs of {} - TestBit ex -> emitExprOp ex >>= testBit Refl + dup :: (HasRewriter sig m, Has (State (Ref, Maybe Ref)) sig m) + => Ref -> m () + dup r1 = do + (r2, mr3) <- get @(Ref, Maybe Ref) + case mr3 of + Nothing -> put (r2, Just r1) + Just r3 -> do + rn4 <- newNode $ const $ DupNode 0 mempty () () () + linkNodes r2 $ Ref rn4 0 + linkNodes r3 $ Ref rn4 1 + put (Ref rn4 2, Just r1) --- | Folds an @IO@ value using the given continuations for each possible value. -foldIO - :: forall t sig r m. Has IRBuilder sig m - => (forall lt. t :~: 'LlvmType lt -> SLlvmType lt -> m r) - -- ^ LLVM-typed expressions - -> (Expr 'Zero '[] t -> m r) - -- ^ Pure expressions - -> (LLVM.Operand -> Expr 'Zero '[] ('IOType t) - -> Expr 'Zero '[] ('IOType t) -> m r) - -- ^ TestBit _ :@ IOType t :$ _ :$ _ - -> Expr 'Zero '[] ('IOType t) -> m r -foldIO llvmIO pureIO testBit3 = \case - Var vidx -> absurd $ zeroNoLT vidx Refl - App ef ex -> foldArrow - (\tx -> foldIO llvmIO pureIO testBit3 - . substituteExpr SZero (tx :^ SNil) SZero ex) - (\Refl -> pureIO ex) - (\_ -> \case {}) - (\Refl Refl tx ey ty -> foldIO - (\Refl lt -> do - op <- emitExprIO ey - foldIO llvmIO pureIO testBit3 $ ex :$ LlvmOperand lt op) - (\ez -> foldIO llvmIO pureIO testBit3 $ ex :$ ez) - (\op et ef' -> foldIO llvmIO pureIO testBit3 - $ withProof (subIncElim SZero SZero ty tx Refl) - $ TestBit (LlvmOperand (SLlvmInt $ SSucc SZero) op) - :@ SIOType ty - :$ (BindIO :@ tx :$ et :@ ty :$ ex) - :$ (BindIO :@ tx :$ ef' :@ ty :$ ex)) - ey) - (\Refl Refl _ -> foldPointer - (\tx pop -> do - let lt = sMarshall tx - op <- emitInstr (llvmType lt) $ LLVM.Load True pop Nothing 1 [] - pureIO $ marshallIn SZero SNil tx $ LlvmOperand lt op) - ex) - (\_ -> \case {}) - (\Refl ey -> foldPointer - (\tx pop -> do - op <- emitExprOp $ marshallOut SZero SNil tx ex - emitInstrVoid $ LLVM.Store True pop op Nothing 1 [] - pureIO $ TypeLam $ STypeVar SZero :\ Var SZero) - ey) - (\Refl Refl _ _ (_ :^ SNil) ltret -> llvmIO Refl ltret) - (\_ -> \case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\case {}) - (\Refl op ey -> testBit3 op ey ex) - (\op ey ez -> testBit3 op (ey :$ ex) (ez :$ ex)) - ef - TypeApp ef tx -> foldForall - (foldIO llvmIO pureIO testBit3 . substituteExprType SZero SNil SZero tx) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\op ey ez -> testBit3 op (ey :@ tx) (ez :@ tx)) - ef - LlvmIO lt _ -> llvmIO Refl lt - Call _ _ SNil ltret -> llvmIO Refl ltret + finish :: HasRewriter sig m => (Ref, Maybe Ref) -> r -> m r + finish (r1, mr2) r = r <$ maybe (propagate1 r1 DeadNode) (linkNodes r1) mr2 --- | Folds a pointer using the given continuations for each possible value. -foldPointer - :: forall pk tx sig r m. Has IRBuilder sig m - => ((MarshallableType tx, IsOpType (Marshall tx) ~ 'True) - => SType 'Zero tx -> LLVM.Operand -> m r) - -> Expr 'Zero '[] ('PointerType pk tx) -> m r -foldPointer addr = \case - Var vidx -> absurd $ zeroNoLT vidx Refl - App ef ex -> foldArrow - (\tx -> foldPointer addr . substituteExpr SZero (tx :^ SNil) SZero ex) - (\case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\case {}) - (\Refl Refl _ _ (_ :^ ltargs) _ -> case ltargs of {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\_ -> \case {}) - (\case {}) - (\Refl op ey -> emitSelect' op ey ex) - (\op ey ez -> emitSelect' op (ey :$ ex) (ez :$ ex)) - ef - TypeApp ef tx -> foldForall - (foldPointer addr . substituteExprType SZero SNil SZero tx) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\case {}) - (\op ey ez -> emitSelect' op (ey :@ tx) (ez :@ tx)) - ef - Addr addr' _ tx -> addr tx $ llvmAddress (sMarshall tx) addr' - Call _ _ ltargs _ -> case ltargs of {} - where - emitSelect' - :: LLVM.Operand - -> Expr 'Zero '[] ('PointerType pk tx) - -> Expr 'Zero '[] ('PointerType pk tx) - -> m r - emitSelect' opc et ef = foldPointer (\_ opt -> foldPointer (\_ opf -> do - opr <- emitInstr (llvmType $ sMarshall tx) - $ LLVM.Select opc opt opf [] - addr tx opr - ) ef) et - where - SPointerType _ tx = exprType SZero SNil et - --- | Converts an t'LlvmType' into an LLVM type in the LLVM AST. -llvmType :: SLlvmType t -> LLVM.Type -llvmType = \case - SLlvmInt size -> case sCmpNat size SZero of - SLT -> absurd $ zeroNoLT size Refl - SEQ -> LLVM.VoidType - SGT -> LLVM.IntegerType $ fromIntegral $ toNatural size +-- | Converts a t'BackendType' into a backend type in the backend AST. +backendType :: SBackendType t -> Backend.Type +backendType (SBackendInt size) = Backend.IntType $ fromIntegral $ toNatural size --- | Converts a foreign name to a name in the LLVM AST. -llvmForeignName :: ForeignName -> LLVM.Name -llvmForeignName (ForeignName t) = LLVM.Name $ toShortByteString t - -{-| - Converts an address to an LLVM operand representing that address. The given - t'LlvmType' is used to determine the type of the operand. --} -llvmAddress :: SLlvmType lt -> Address -> LLVM.Operand -llvmAddress lt (Address addr) = LLVM.ConstantOperand - $ LLVM.Constant.IntToPtr (LLVM.Constant.Int (log2 addr) $ fromIntegral addr) - $ LLVM.Type.ptr $ llvmType lt - where - log2 0 = error "Address is 0" - log2 n = fromIntegral $ naturalLog2 n + 1 +-- | Converts a foreign name to a name in the backend AST. +backendForeignName :: ForeignName -> Backend.Name +backendForeignName (ForeignName t) = Backend.ExternalName $ toShortByteString t -- GHC gives a nonexhaustive pattern warning if this is inlined. :/ -- | Calls a continuation with a proof relating 'AllIsOpType' and 'IsOpType'. withAllIsOpTypeProof - :: AllIsOpType (lt ': lts) ~ 'True => SLlvmType lt -> proxy lts + :: AllIsOpType (lt ': lts) ~ 'True => SBackendType lt -> proxy lts -> ((IsOpType lt ~ 'True, AllIsOpType lts ~ 'True) => r') -> r' withAllIsOpTypeProof lt _ x = case sIsOpType lt of STrue -> x + diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs new file mode 100644 index 0000000..8b220f6 --- /dev/null +++ b/src/Language/Elemental/InteractionNet.hs @@ -0,0 +1,1027 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-| + Interaction net based evaluator for compiling Elemental. + + This evaluator makes the following assumptions about the input: + - The program is total. + - There are no edges between ports whose types don't unify. + - IO is never duplicated, eliminated, or branched without a continuation. + + The easiest way of using the evaluator is to use 'compileINet'. + + Should you choose to manually generate an interaction net instead of using + existing functions, be careful not to violate these assumptions, else your + net may fail to evaluate. + + For better performance, the evaluator tracks redundant data about the net: + interacting nodes are stored in 'INetPairs'. The evaluator assumes that the + data stored there is correct and complete, and it will neither verify that a + pair is interacting nor look elsewhere for missing interacting pairs. Hence, + it is highly recommended to only use the exported helper functions, never + manually change 'INet' or 'INetPairs', and always keep an 'INet' and its + 'INetPairs' together. +-} +module Language.Elemental.InteractionNet + ( INet(..) + , _INet + , INetPairs(..) + , _INetPairs + , INetSize(..) + , _INetSize + , INetF(..) + , Ref(..) + , Level(..) + , Preaction(..) + , Renames + , HasRewriter + , compileINet + , reduce + , propagate1 + , propagate2 + , mkLambda + , newNode + , newNodeIndex + , linkNodes + -- * Debugging + , TraceRewrite(..) + , traceRewrite + ) where + +import Control.Algebra (Has, send) +import Control.Carrier.Writer.Church (Writer, execWriter, tell) +import Control.Effect.State (State, get, gets, modify) +import Control.Lens.At (At(at), Index, Ixed(ix), IxValue) +import Control.Lens.Cons (_head) +import Control.Lens.Fold (IndexedFold, filtered, folded, imapMOf_, (^..), (^?)) +import Control.Lens.Getter (to) +import Control.Lens.Indexed (Indexed(Indexed), indexing) +import Control.Lens.Iso (Iso', iso) +import Control.Lens.Setter ((.~), (%~), (?~)) +import Control.Lens.Traversal (traversed) +import Control.Lens.Wrapped (_Wrapped) +import Data.Bifunctor (second) +import Data.DList (DList, toList) +import Data.Foldable (find) +import Data.IntMap.Strict qualified as IM +import Data.IntSet qualified as IS +import Data.Map.Lazy qualified as M +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) +import Prettyprinter + +import Language.Elemental.Backend qualified as B +import Language.Elemental.Singleton + +newtype INet = INet { unINet :: IM.IntMap (INetF Ref) } + deriving newtype (Semigroup, Monoid) + +instance Pretty INet where + pretty = concatWith mkLine . fmap go . IM.assocs . unINet + where + go (idx, v) = pretty idx <+> "=" <+> pretty v + mkLine a b = a <> line <> b + +instance Ixed INet where + ix idx = _INet . ix idx + {-# INLINE ix #-} + +instance At INet where + at idx = _INet . at idx + {-# INLINE at #-} + +type instance Index INet = Int +type instance IxValue INet = INetF Ref + +_INet :: Iso' INet (IM.IntMap (INetF Ref)) +_INet = iso unINet INet +{-# INLINE _INet #-} + +newtype INetPairs = INetPairs { unINetPairs :: IS.IntSet } + deriving newtype (Semigroup, Monoid) + +_INetPairs :: Iso' INetPairs IS.IntSet +_INetPairs = iso unINetPairs INetPairs +{-# INLINE _INetPairs #-} + +data Ref = Ref + { refNode :: Int + , refPort :: Int + } deriving stock (Eq, Ord, Show) + +instance Pretty Ref where + pretty r0 = pretty (refNode r0) <> ":" <> pretty (refPort r0) + +data INetF a + -- | (a -> b, a, b) + = AppNode a a a + -- | (a -> b, a, b) + | LamNode a a a + -- | (a, a, a) + | DupNode Level Renames a a a + -- | Void (i.e. any type) + | DeadNode a + -- | (a, a) and the non-principal node is in a new box. + | BoxNode Level a a + -- FFI + -- | IO i{n} + | RootNode B.Name [B.Named B.Type] a + -- | i{n} + | OperandNode B.Operand a + -- | (i{n}, {... ->} i{n}) + | OperandPNode (B.Partial B.Operand) a a + -- | IO i{n} + | IONode B.Body a + -- | (i{n}, {... ->} i{n}) + | IOPNode (B.Partial B.Instruction) a a + -- | (IO a, IO a) + | IOContNode Preaction a a + -- | (a, IO a) + | Pure0Node a a + -- | (IO a, (a -> IO b) -> IO b) + | Bind0Node a a + -- | (IO b, IO b) + | Bind1Node Preaction a a + -- | (i1, a -> a -> a) + | Branch0Node Level a a + -- | (a, a -> a) + | Branch1Node Level B.Operand a a + -- | (IO a, a, IO a) + | Branch2BNode Level B.Operand Preaction a a a + -- | (IO (a -> b), a, b, IO (a -> b)) + | Branch2PNode Level B.Operand a a a a + deriving stock (Foldable, Functor, Traversable) + +instance Pretty a => Pretty (INetF a) where + pretty (AppNode r0 r1 r2) = "App" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (LamNode r0 r1 r2) = "Lam" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (DupNode lvl _ r0 r1 r2) + = "Dup" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (DeadNode r0) = "Dead" <+> pretty r0 + pretty (BoxNode lvl r0 r1) + = "Box" <+> pretty lvl <+> pretty r0 <+> pretty r1 + pretty (RootNode name args r0) + = "Root" <+> pretty r0 <+> pretty name <+> tupled (pretty <$> args) + pretty (OperandNode op r0) = "Operand" <+> pretty r0 <+> pretty op + pretty (OperandPNode opp r0 r1) + = "OperandP" <+> pretty r0 <+> pretty r1 <+> pretty opp + pretty (IONode b r0) = "IO" <+> pretty r0 <> nest 4 (line <> pretty b) + pretty (IOPNode iop r0 r1) + = "IOP" <+> pretty r0 <+> pretty r1 <+> pretty iop + pretty (IOContNode nbs r0 r1) + = "IOCont" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty nbs) + pretty (Pure0Node r0 r1) = "Pure0" <+> pretty r0 <+> pretty r1 + pretty (Bind0Node r0 r1) = "Bind0" <+> pretty r0 <+> pretty r1 + pretty (Bind1Node nbs r0 r1) + = "Bind1" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty nbs) + pretty (Branch0Node lvl r0 r1) + = "Branch0" <+> pretty lvl <+> pretty r0 <+> pretty r1 + pretty (Branch1Node lvl op r0 r1) + = "Branch1" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty op + pretty (Branch2BNode lvl opc nbt r0 r1 r2) + = "Branch2B" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 + <+> pretty opc <> nest 4 (line <> pretty nbt) + pretty (Branch2PNode lvl opc r0 r1 r2 r3) + = "Branch2P" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 + <+> pretty r3 <+> pretty opc + +instance Ixed (INetF a) where + ix idx f = indexing traverse $ Indexed go + where + go idx' x + | idx == idx' = f x + | otherwise = pure x + {-# INLINE ix #-} + +type instance Index (INetF a) = Int +type instance IxValue (INetF a) = a + +newtype Level = Level { unLevel :: Int } + deriving newtype (Enum, Eq, Ord, Num, Pretty) + +-- | Instructions that should run before a continuation. +data Preaction + = SimplePreaction B.Name B.Body + | BranchPreaction B.Operand Preaction Preaction + | ConcatPreaction Preaction Preaction + | EmptyPreaction + +instance Semigroup Preaction where + (<>) = ConcatPreaction + +instance Monoid Preaction where + mempty = EmptyPreaction + +instance Pretty Preaction where + pretty (SimplePreaction name b) = pretty name <+> "=" <+> pretty b + pretty (BranchPreaction op nb1 nb2) = "If" <+> pretty op <+> "Then" + <> nest 4 (line <> pretty nb1) <> line <> "Else" + <> nest 4 (line <> pretty nb2) <> line <> "End" + pretty (ConcatPreaction nb1 nb2) = pretty nb1 <> line <> pretty nb2 + pretty EmptyPreaction = "_ = []" + +type Renames = M.Map B.Name (B.Operand, B.Operand) + +compileINet + :: (HasRewriter sig m, Has TraceRewrite sig m) + => [B.Named B.External] -> m B.Program +compileINet exts = B.Program exts . toList <$> execWriter reduce +{-# INLINABLE compileINet #-} + +reduce + :: (HasRewriter sig m, Has TraceRewrite sig m + , Has (Writer (DList (B.Named B.Function))) sig m) + => m () +reduce = try *> lintFinal + where + go r0 = do + net <- get + let r1 = derefPort n0 0 + n1 = derefNode net $ refNode r1 + n0 = derefNode net $ refNode r0 + traceRewrite r0 r1 n0 n1 $ do + reduceNode n0 n1 + safeDelete r0 n0 + safeDelete r1 n1 + try + + try :: (HasRewriter sig m, Has TraceRewrite sig m + , Has (Writer (DList (B.Named B.Function))) sig m) + => m () + try = do + net <- get + case net ^? _INetPairs . _Wrapped . _head of + Nothing -> pure () + Just rn0 -> go $ Ref rn0 0 + + isRoot :: INetF Ref -> Bool + isRoot RootNode {} = True + isRoot _ = False + + derefNode :: INet -> Int -> INetF Ref + derefNode net rn0 = fromMaybe (error "reduce: missing node") + $ net ^? ix rn0 + + derefPort :: INetF Ref -> Int -> Ref + derefPort n0 r1 = fromMaybe (error "reduce: missing port") + $ n0 ^? ix r1 + + -- Handling self-reference during reduction is far more tedious. + safeDelete :: HasRewriter sig m => Ref -> INetF Ref -> m () + safeDelete (Ref rn0 _) n0 = do + imapMOf_ targets relink n0 + modify $ _INet . at rn0 .~ Nothing + modify $ _INetPairs %~ IS.delete rn0 + where + targets :: IndexedFold Int (INetF Ref) Int + targets = traversed . filtered ((== rn0) . refNode) . to refPort + + relink :: HasRewriter sig m => Int -> Int -> m () + relink rp1 rp2 = do + net <- get + let n3 = derefNode net rn0 + linkNodes (derefPort n3 rp1) (derefPort n3 rp2) + + lintFinal :: HasRewriter sig m => m () + lintFinal = do + net <- get + case find isRoot $ unINet net of + Nothing -> pure () + Just _ -> error . show $ "lint: failed to reduce root" + <> line <> pretty net +{-# INLINABLE reduce #-} + +reduceNode + :: (HasRewriter sig m, Has (Writer (DList (B.Named B.Function))) sig m) + => INetF Ref -> INetF Ref -> m () +reduceNode (AppNode _ r0 r1) (AppNode _ r2 r3) + = linkNodes r0 r1 *> linkNodes r2 r3 +reduceNode (AppNode _ r0 r1) (LamNode _ r2 r3) = do + rn4 <- newNode $ const $ BoxNode 0 () () + rn5 <- newNode $ const $ BoxNode 0 () () + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn5 0 + linkNodes r2 $ Ref rn4 1 + linkNodes r3 $ Ref rn5 1 +reduceNode n0@LamNode {} n1@AppNode {} = reduceNode n1 n0 +reduceNode (AppNode _ r0 r1) (DupNode lvl re _ r2 r3) + = commute2 AppNode (DupNode lvl re) r0 r1 r2 r3 +reduceNode n0@DupNode {} n1@AppNode {} = reduceNode n1 n0 +reduceNode (LamNode _ r0 r1) (DupNode lvl re _ r2 r3) + = commute2 LamNode (DupNode (succ lvl) re) r0 r1 r2 r3 +reduceNode n0@DupNode {} n1@LamNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl1 re1 _ r0 r1) (DupNode lvl2 re2 _ r2 r3) + | lvl1 == lvl2 = linkNodes r0 r2 *> linkNodes r1 r3 + | otherwise = commute2 (DupNode lvl1 re1) (DupNode lvl2 re2) r0 r1 r2 r3 +reduceNode (AppNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode n0@DeadNode {} n1@AppNode {} = reduceNode n1 n0 +reduceNode (LamNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode n0@DeadNode {} n1@LamNode {} = reduceNode n1 n0 +reduceNode (DupNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode n0@DeadNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DeadNode _) (DeadNode _) = pure () +-- Book-keeping +reduceNode (AppNode _ r0 r1) (BoxNode lvl _ r2) + = commute1 AppNode (BoxNode lvl) r0 r1 r2 +reduceNode n0@BoxNode {} n1@AppNode {} = reduceNode n1 n0 +reduceNode (LamNode _ r0 r1) (BoxNode lvl _ r2) + = commute1 LamNode (BoxNode $ succ lvl) r0 r1 r2 +reduceNode n0@BoxNode {} n1@LamNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 re _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (DupNode (if lvl0 < lvl1 then lvl0 else succ lvl0) re) + (BoxNode lvl1) + r0 r1 r2 +reduceNode n0@BoxNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (BoxNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@BoxNode {} = reduceNode n1 n0 +reduceNode (BoxNode lvl0 _ r0) (BoxNode lvl1 _ r1) + | lvl0 == lvl1 = linkNodes r0 r1 + | otherwise = commute0 + (BoxNode $ if lvl0 < lvl1 then lvl0 else succ lvl0) + (BoxNode $ if lvl1 < lvl0 then lvl1 else succ lvl1) + r0 r1 +-- FFI +reduceNode (RootNode name args _) (IONode b _) + = tell $ pure @DList $ name B.:= B.Function args b +reduceNode n0@IONode {} n1@RootNode {} = reduceNode n1 n0 +reduceNode (OperandPNode opp _ r0) (OperandNode op _) + = case B.addOperand op opp of + Left opp' -> mkLambda r0 $ OperandPNode opp' + Right op' -> propagate1 r0 $ OperandNode op' +reduceNode n0@OperandNode {} n1@OperandPNode {} = reduceNode n1 n0 +reduceNode (IOPNode iop _ r0) (OperandNode op _) + = case B.addOperand op iop of + Left iop' -> mkLambda r0 $ IOPNode iop' + Right instr -> propagate1 r0 $ IONode $ B.Body mempty instr +reduceNode n0@OperandNode {} n1@IOPNode {} = reduceNode n1 n0 +reduceNode (Pure0Node _ r0) (LamNode _ r1 r2) = do + rn3 <- newNode $ const $ IOContNode mempty () () + rn4 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes r0 $ Ref rn3 0 + linkNodes r1 $ Ref rn4 1 + linkNodes r2 $ Ref rn4 2 +reduceNode n0@LamNode {} n1@Pure0Node {} = reduceNode n1 n0 +reduceNode (Pure0Node _ r0) (OperandNode op _) + = propagate1 r0 $ IONode $ B.Body mempty $ B.Pure op +reduceNode n0@OperandNode {} n1@Pure0Node {} = reduceNode n1 n0 +reduceNode (Pure0Node _ r0) (IONode b _) = do + rn3 <- newNode $ const $ IOContNode mempty () () + rn4 <- newNode $ const $ IONode b () + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes r0 $ Ref rn3 0 +reduceNode n0@IONode {} n1@Pure0Node {} = reduceNode n1 n0 +reduceNode (Pure0Node _ r0) (IOContNode nbs _ r1) = do + rn3 <- newNode $ const $ IOContNode mempty () () + rn4 <- newNode $ const $ IOContNode nbs () () + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes r0 $ Ref rn3 0 + linkNodes r1 $ Ref rn4 1 +reduceNode n0@IOContNode {} n1@Pure0Node {} = reduceNode n1 n0 +reduceNode (Bind0Node _ r0) (IOContNode nbs _ r1) = do + rn2 <- newNode $ const $ Bind1Node nbs () () + rn3 <- newNode $ const $ AppNode () () () + rn4 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn2 0) (Ref rn3 2) + linkNodes (Ref rn2 1) (Ref rn4 2) + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn3 1 +reduceNode n0@IOContNode {} n1@Bind0Node {} = reduceNode n1 n0 +reduceNode (Bind0Node _ r0) (IONode b _) = do + rn1 <- newNode $ \rn1 -> Bind1Node (SimplePreaction (mkName rn1) b) () () + let t = B.instrType $ B.bodyTerm b + rn2 <- newNode $ const $ OperandNode (mkRef t rn1) () + rn3 <- newNode $ const $ AppNode () () () + rn4 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn1 0) (Ref rn3 2) + linkNodes (Ref rn1 1) (Ref rn4 2) + linkNodes (Ref rn2 0) (Ref rn3 1) + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes r0 $ Ref rn4 0 +reduceNode n0@IONode {} n1@Bind0Node {} = reduceNode n1 n0 +reduceNode (Bind1Node nbs _ r0) (IONode b2 _) + = propagate1 r0 $ IONode $ applyCont nbs b2 +reduceNode n0@IONode {} n1@Bind1Node {} = reduceNode n1 n0 +reduceNode (Bind1Node nbs1 _ r0) (IOContNode nbs2 _ r1) = do + rn2 <- newNode $ const $ IOContNode (nbs1 <> nbs2) () () + linkNodes r0 $ Ref rn2 0 + linkNodes r1 $ Ref rn2 1 +reduceNode n0@IOContNode {} n1@Bind1Node {} = reduceNode n1 n0 +reduceNode (Branch0Node lvl _ r0) (OperandNode op _) + = mkLambda r0 $ Branch1Node lvl op +reduceNode n0@OperandNode {} n1@Branch0Node {} = reduceNode n1 n0 +reduceNode (Branch1Node lvl op _ r0) (LamNode _ r1 r2) = do + rn3 <- newNode $ const $ Branch2PNode lvl op () () () () + rn4 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes (Ref rn3 3) (Ref rn4 2) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn3 1 + linkNodes r2 $ Ref rn3 2 +reduceNode n0@LamNode {} n1@Branch1Node {} = reduceNode n1 n0 +reduceNode (Branch1Node _ opc _ r0) (OperandNode opt _) = mkLambda r0 + $ OperandPNode $ B.Partial (SSucc SZero) $ mkSelect opc opt +reduceNode n0@OperandNode {} n1@Branch1Node {} = reduceNode n1 n0 +reduceNode (Branch1Node lvl op _ r0) (IOContNode nbs _ r1) = do + rn3 <- newNode $ const $ Branch2BNode lvl op nbs () () () + rn4 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes (Ref rn3 2) (Ref rn4 2) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn3 1 +reduceNode n0@IOContNode {} n1@Branch1Node {} = reduceNode n1 n0 +reduceNode (Branch2BNode lvl op nbs1 _ r0 r1) (IOContNode nbs2 _ r2) = do + let nbs = BranchPreaction op nbs1 nbs2 + rn3 <- newNode $ const $ Branch1Node lvl op () () + rn4 <- newNode $ const $ AppNode () () () + rn5 <- newNode $ const $ IOContNode nbs () () + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes (Ref rn4 2) (Ref rn5 1) + linkNodes r0 $ Ref rn3 0 + linkNodes r1 $ Ref rn5 0 + linkNodes r2 $ Ref rn4 1 +reduceNode n0@IOContNode {} n1@Branch2BNode {} = reduceNode n1 n0 +reduceNode (Branch2PNode lvl opc _ r0 r1 r2) (LamNode _ r3 r4) = do + rn4 <- newNode $ const $ Branch1Node lvl opc () () + rn5 <- newNode $ const $ AppNode () () () + rn6 <- newNode $ const $ DupNode lvl mempty () () () + rn7 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn4 1) (Ref rn5 0) + linkNodes (Ref rn5 2) (Ref rn7 2) + linkNodes (Ref rn6 0) (Ref rn7 1) + linkNodes r0 $ Ref rn6 1 + linkNodes r1 $ Ref rn4 0 + linkNodes r2 $ Ref rn7 0 + linkNodes r3 $ Ref rn6 2 + linkNodes r4 $ Ref rn5 1 +reduceNode n0@LamNode {} n1@Branch2PNode {} = reduceNode n1 n0 +-- FFI Duplication +reduceNode (DupNode _ re _ r0 r1) (OperandNode op _) + = copyIO1 r0 r1 OperandNode B.renameOp re op +reduceNode n0@OperandNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl re _ r0 r1) (OperandPNode opp _ r2) + = copyIO2 lvl r0 r1 r2 OperandPNode (fmap . B.renameOp) re opp +reduceNode n0@OperandPNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl re _ r0 r1) (IOPNode iop _ r2) + = copyIO2 lvl r0 r1 r2 IOPNode (fmap . B.renameInstr) re iop +reduceNode n0@IOPNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl re _ r0 r1) (IOContNode nbs _ r2) + = shareIOCont lvl re nbs r0 r1 r2 +reduceNode n0@IOContNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl re _ r0 r1) (Pure0Node _ r2) + = commute1 (DupNode lvl re) Pure0Node r0 r1 r2 +reduceNode n0@Pure0Node {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl re _ r0 r1) (Bind0Node _ r2) + = commute1 (DupNode lvl re) Bind0Node r0 r1 r2 +reduceNode n0@Bind0Node {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl re _ r0 r1) (Bind1Node nbs _ r2) + = shareBind1 lvl re nbs r0 r1 r2 +reduceNode n0@Bind1Node {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 re _ r0 r1) (Branch0Node lvl1 _ r2) + = commute1 (DupNode lvl0 re) (Branch0Node lvl1) r0 r1 r2 +reduceNode n0@Branch0Node {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 re _ r0 r1) (Branch1Node lvl1 op _ r2) + = copyIO2 lvl0 r0 r1 r2 (Branch1Node lvl1) B.renameOp re op +reduceNode n0@Branch1Node {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 re _ r0 r1) (Branch2BNode lvl1 opc nbt _ r2 r3) + = shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 +reduceNode n0@Branch2BNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 re _ r0 r1) (Branch2PNode lvl1 op _ r2 r3 r4) + = commute3' (DupNode lvl0 re) + (Branch2PNode lvl1 $ B.renameOp (M.map fst re) op) + (Branch2PNode lvl1 $ B.renameOp (M.map snd re) op) + r0 r1 r2 r3 r4 +reduceNode n0@Branch2PNode {} n1@DupNode {} = reduceNode n1 n0 +-- FFI Dead +reduceNode (OperandNode _ _) (DeadNode _) = pure () +reduceNode n0@DeadNode {} n1@OperandNode {} = reduceNode n1 n0 +reduceNode (OperandPNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@OperandPNode {} = reduceNode n1 n0 +reduceNode (IOPNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@IOPNode {} = reduceNode n1 n0 +reduceNode (IOContNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@IOContNode {} = reduceNode n1 n0 +reduceNode (Pure0Node _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@Pure0Node {} = reduceNode n1 n0 +reduceNode (Bind0Node _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@Bind0Node {} = reduceNode n1 n0 +reduceNode (Bind1Node _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@Bind1Node {} = reduceNode n1 n0 +reduceNode (Branch0Node _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@Branch0Node {} = reduceNode n1 n0 +reduceNode (Branch1Node _ _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@Branch1Node {} = reduceNode n1 n0 +reduceNode (Branch2BNode _ _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode n0@DeadNode {} n1@Branch2BNode {} = reduceNode n1 n0 +reduceNode (Branch2PNode _ _ _ r0 r1 r2) (DeadNode _) + = propagate3 r0 r1 r2 DeadNode +reduceNode n0@DeadNode {} n1@Branch2PNode {} = reduceNode n1 n0 +-- FFI Book-keeping +reduceNode (RootNode name args _) (BoxNode _ _ r0) + = propagate1 r0 $ RootNode name args +reduceNode n0@BoxNode {} n1@RootNode {} = reduceNode n1 n0 +reduceNode (OperandNode op _) (BoxNode _ _ r0) + = propagate1 r0 $ OperandNode op +reduceNode n0@BoxNode {} n1@OperandNode {} = reduceNode n1 n0 +reduceNode (OperandPNode opp _ r0) (BoxNode lvl _ r1) + = commute0 (OperandPNode opp) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@OperandPNode {} = reduceNode n1 n0 +reduceNode (IONode b _) (BoxNode _ _ r0) + = propagate1 r0 $ IONode b +reduceNode n0@BoxNode {} n1@IONode {} = reduceNode n1 n0 +reduceNode (IOPNode iop _ r0) (BoxNode lvl _ r1) + = commute0 (IOPNode iop) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@IOPNode {} = reduceNode n1 n0 +reduceNode (IOContNode nbs _ r0) (BoxNode lvl _ r1) + = commute0 (IOContNode nbs) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@IOContNode {} = reduceNode n1 n0 +reduceNode (Pure0Node _ r0) (BoxNode lvl _ r1) + = commute0 Pure0Node (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@Pure0Node {} = reduceNode n1 n0 +reduceNode (Bind0Node _ r0) (BoxNode lvl _ r1) + = commute0 Bind0Node (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@Bind0Node {} = reduceNode n1 n0 +reduceNode (Bind1Node nbs _ r0) (BoxNode lvl _ r1) + = commute0 (Bind1Node nbs) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@Bind1Node {} = reduceNode n1 n0 +reduceNode (Branch0Node lvl0 _ r0) (BoxNode lvl1 _ r1) = commute0 + (Branch0Node $ if lvl0 < lvl1 then lvl0 else succ lvl0) (BoxNode lvl1) r0 r1 +reduceNode n0@BoxNode {} n1@Branch0Node {} = reduceNode n1 n0 +reduceNode (Branch1Node lvl0 op _ r0) (BoxNode lvl1 _ r1) = commute0 + (Branch1Node (if lvl0 < lvl1 then lvl0 else succ lvl0) op) + (BoxNode lvl1) + r0 r1 +reduceNode n0@BoxNode {} n1@Branch1Node {} = reduceNode n1 n0 +reduceNode (Branch2BNode lvl0 opc nbt _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (Branch2BNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc nbt) + (BoxNode lvl1) + r0 r1 r2 +reduceNode n0@BoxNode {} n1@Branch2BNode {} = reduceNode n1 n0 +reduceNode (Branch2PNode lvl0 opc _ r0 r1 r2) (BoxNode lvl1 _ r3) = commute1b + (Branch2PNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc) + (BoxNode lvl1) + r0 r1 r2 r3 +reduceNode n0@BoxNode {} n1@Branch2PNode {} = reduceNode n1 n0 +reduceNode n0 n1 = error . show + $ "unexpected node pairing" <> line <> pretty n0 <> line <> pretty n1 +{-# INLINABLE reduceNode #-} + +commute0 + :: HasRewriter sig m + => (() -> () -> INetF ()) -> (() -> () -> INetF ()) + -> Ref -> Ref -> m () +commute0 mk1 mk2 r0 r1 = do + rn3 <- newNode $ const $ mk2 () () + rn4 <- newNode $ const $ mk1 () () + linkNodes (Ref rn3 1) (Ref rn4 1) + linkNodes r0 $ Ref rn3 0 + linkNodes r1 $ Ref rn4 0 +{-# INLINABLE commute0 #-} + +commute1 + :: HasRewriter sig m + => (() -> () -> () -> INetF ()) -> (() -> () -> INetF ()) + -> Ref -> Ref -> Ref -> m () +commute1 mk1 mk2 = commute1' mk1 mk2 mk2 +{-# INLINABLE commute1 #-} + +commute1' + :: HasRewriter sig m + => (() -> () -> () -> INetF ()) + -> (() -> () -> INetF ()) -> (() -> () -> INetF ()) + -> Ref -> Ref -> Ref -> m () +commute1' mk1 mk2a mk2b r0 r1 r2 = do + rn3 <- newNode $ const $ mk2a () () + rn4 <- newNode $ const $ mk2b () () + rn5 <- newNode $ const $ mk1 () () () + linkNodes (Ref rn3 1) (Ref rn5 1) + linkNodes (Ref rn4 1) (Ref rn5 2) + linkNodes r0 $ Ref rn3 0 + linkNodes r1 $ Ref rn4 0 + linkNodes r2 $ Ref rn5 0 +{-# INLINABLE commute1' #-} + +commute1b + :: HasRewriter sig m + => (() -> () -> () -> () -> INetF ()) -> (() -> () -> INetF ()) + -> Ref -> Ref -> Ref -> Ref -> m () +commute1b mk1 mk2 r0 r1 r2 r3 = do + rn4 <- newNode $ const $ mk2 () () + rn5 <- newNode $ const $ mk2 () () + rn6 <- newNode $ const $ mk2 () () + rn7 <- newNode $ const $ mk1 () () () () + linkNodes (Ref rn4 1) (Ref rn7 1) + linkNodes (Ref rn5 1) (Ref rn7 2) + linkNodes (Ref rn6 1) (Ref rn7 3) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn5 0 + linkNodes r2 $ Ref rn6 0 + linkNodes r3 $ Ref rn7 0 +{-# INLINABLE commute1b #-} + +commute2 + :: HasRewriter sig m + => (() -> () -> () -> INetF ()) + -> (() -> () -> () -> INetF ()) + -> Ref -> Ref -> Ref -> Ref -> m () +commute2 mk1 mk2 = commute2' mk1 mk1 mk2 mk2 +{-# INLINABLE commute2 #-} + +commute2' + :: HasRewriter sig m + => (() -> () -> () -> INetF ()) + -> (() -> () -> () -> INetF ()) + -> (() -> () -> () -> INetF ()) + -> (() -> () -> () -> INetF ()) + -> Ref -> Ref -> Ref -> Ref -> m () +commute2' mk1a mk1b mk2a mk2b r0 r1 r2 r3 = do + rn4 <- newNode $ const $ mk1a () () () + rn5 <- newNode $ const $ mk1b () () () + rn6 <- newNode $ const $ mk2a () () () + rn7 <- newNode $ const $ mk2b () () () + linkNodes (Ref rn4 1) (Ref rn6 1) + linkNodes (Ref rn4 2) (Ref rn7 1) + linkNodes (Ref rn5 1) (Ref rn6 2) + linkNodes (Ref rn5 2) (Ref rn7 2) + linkNodes r0 $ Ref rn6 0 + linkNodes r1 $ Ref rn7 0 + linkNodes r2 $ Ref rn4 0 + linkNodes r3 $ Ref rn5 0 +{-# INLINABLE commute2' #-} + +commute3' + :: HasRewriter sig m + => (() -> () -> () -> INetF ()) + -> (() -> () -> () -> () -> INetF ()) + -> (() -> () -> () -> () -> INetF ()) + -> Ref -> Ref -> Ref -> Ref -> Ref -> m () +commute3' mk1 mk2a mk2b r0 r1 r2 r3 r4 = do + rn5 <- newNode $ const $ mk1 () () () + rn6 <- newNode $ const $ mk1 () () () + rn7 <- newNode $ const $ mk1 () () () + rn8 <- newNode $ const $ mk2a () () () () + rn9 <- newNode $ const $ mk2b () () () () + linkNodes (Ref rn5 1) (Ref rn8 1) + linkNodes (Ref rn5 2) (Ref rn9 1) + linkNodes (Ref rn6 1) (Ref rn8 2) + linkNodes (Ref rn6 2) (Ref rn9 2) + linkNodes (Ref rn7 1) (Ref rn8 3) + linkNodes (Ref rn7 2) (Ref rn9 3) + linkNodes r0 $ Ref rn8 0 + linkNodes r1 $ Ref rn9 0 + linkNodes r2 $ Ref rn5 0 + linkNodes r3 $ Ref rn6 0 + linkNodes r4 $ Ref rn7 0 +{-# INLINABLE commute3' #-} + +propagate1 :: HasRewriter sig m => Ref -> (() -> INetF ()) -> m () +propagate1 r0 mk1 = do + rn1 <- newNode $ const $ mk1 () + linkNodes r0 $ Ref rn1 0 +{-# INLINABLE propagate1 #-} + +propagate2 :: HasRewriter sig m => Ref -> Ref -> (() -> INetF ()) -> m () +propagate2 r0 r1 mk1 = propagate1 r0 mk1 *> propagate1 r1 mk1 +{-# INLINABLE propagate2 #-} + +propagate3 + :: HasRewriter sig m => Ref -> Ref -> Ref -> (() -> INetF ()) -> m () +propagate3 r0 r1 r2 mk1 = propagate2 r0 r1 mk1 *> propagate1 r2 mk1 +{-# INLINABLE propagate3 #-} + +copyIO1 + :: HasRewriter sig m + => Ref -> Ref -> (a -> () -> INetF ()) + -> (M.Map B.Name B.Operand -> a -> a) -> Renames -> a + -> m () +copyIO1 r0 r1 mk1 f re ffi = do + propagate1 r0 $ mk1 $ f (M.map fst re) ffi + propagate1 r1 $ mk1 $ f (M.map snd re) ffi +{-# INLINABLE copyIO1 #-} + +copyIO2 + :: HasRewriter sig m + => Level -> Ref -> Ref -> Ref -> (a -> () -> () -> INetF ()) + -> (M.Map B.Name B.Operand -> a -> a) -> Renames -> a + -> m () +copyIO2 lvl r0 r1 r2 mk1 f re ffi = commute1' (DupNode lvl re) + (mk1 $ f (M.map fst re) ffi) + (mk1 $ f (M.map snd re) ffi) r0 r1 r2 +{-# INLINABLE copyIO2 #-} + +copyIO3 + :: HasRewriter sig m + => Level -> Ref -> Ref -> Ref -> Ref -> (a -> () -> () -> () -> INetF ()) + -> (M.Map B.Name B.Operand -> a -> a) -> Renames -> a + -> m () +copyIO3 lvl r0 r1 r2 r3 mk1 f re ffi = commute2' + (DupNode lvl re) (DupNode lvl re) + (mk1 $ f (M.map fst re) ffi) + (mk1 $ f (M.map snd re) ffi) + r0 r1 r2 r3 +{-# INLINABLE copyIO3 #-} + +shareIOCont + :: HasRewriter sig m + => Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () +shareIOCont = sharePreaction (<>) (pure pure) (pure pure) IOContNode +{-# INLINABLE shareIOCont #-} + +shareBind1 + :: HasRewriter sig m + => Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () +shareBind1 lvl = sharePreaction (const id) (wrap fst) (wrap snd) Bind1Node lvl + where + wrap sel re r0 = do + rn1 <- newNode $ const $ DupNode lvl re () () () + rn2 <- newNode $ const $ DeadNode () + linkNodes (Ref rn1 $ sel (2, 1)) (Ref rn2 0) + linkNodes r0 $ Ref rn1 $ sel (1, 2) + pure $ Ref rn1 0 +{-# INLINABLE shareBind1 #-} + +shareBranch2B + :: HasRewriter sig m + => Level -> Level -> Renames -> B.Operand -> Preaction + -> Ref -> Ref -> Ref -> Ref -> m () +shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 = case sharePreaction' nbt of + Nothing -> copyIO3 lvl0 r0 r1 r2 r3 mk renamePreaction re nbt + Just (name, sb) | null (B.bodyInstrs sb) -> do + let mkPreaction rn = SimplePreaction (mkName rn) sb + rn4 <- newNode $ \rn4 -> mk (mkPreaction rn4) () () () + rn5 <- newNode $ \rn5 -> mk (mkPreaction rn5) () () () + let re' = M.singleton name (mkRef t rn4, mkRef t rn5) + t = B.instrType $ B.bodyTerm sb + rn6 <- newNode $ const $ DupNode lvl0 re () () () + rn7 <- newNode $ const $ DupNode lvl0 re () () () + r8 <- w1 re' $ Ref rn4 0 + r9 <- w2 re' $ Ref rn5 0 + linkNodes (Ref rn4 1) (Ref rn6 1) + linkNodes (Ref rn5 1) (Ref rn6 2) + linkNodes (Ref rn4 2) (Ref rn7 1) + linkNodes (Ref rn5 2) (Ref rn7 2) + linkNodes r0 r8 + linkNodes r1 r9 + linkNodes r2 $ Ref rn6 0 + linkNodes r3 $ Ref rn7 0 + Just (name, sb) -> do + let names = preactionNames nbt + extraArgs = sb ^.. B.bodyFreeRefs + args = M.assocs re + args' = uncurry (B.:=) + <$> (swap <$> extraArgs) + <> (second (B.opType . fst) <$> args) + rn4 <- newNode $ \rn4 -> RootNode (mkName rn4) args' () + let mkPreact sel rn = mkCall sel rn + mkCall sel rn = SimplePreaction (mkName rn) $ B.Body mempty + $ B.Call ltt (mkName rn4) + $ (<>) (uncurry B.Reference <$> extraArgs) + $ sel . snd <$> args + sb' = B.concatBody name sb $ B.Body mempty $ B.Pure sop + (sop, gop, ltt) = case names of + [] -> (B.Empty, const $ const B.Empty, B.IntType 0) + [name'] -> (shareRef name', const id, snd name') + _ -> (B.Tuple $ shareRef <$> names, mkGetElement + , B.TupleType $ snd <$> names) + rn5 <- newNode $ const $ IONode sb' () + rn6 <- newNode $ \rn6 -> mk (mkPreact fst rn6) () () () + rn7 <- newNode $ \rn7 -> mk (mkPreact snd rn7) () () () + let re' = M.fromList $ zipWith (dupNames gop ltt rn5 rn6) [0..] names + rn8 <- newNode $ const $ DupNode lvl0 re () () () + rn9 <- newNode $ const $ DupNode lvl0 re () () () + r10 <- w1 re' (Ref rn6 0) + r11 <- w2 re' (Ref rn7 0) + linkNodes (Ref rn4 0) (Ref rn5 0) + linkNodes (Ref rn6 1) (Ref rn8 1) + linkNodes (Ref rn7 1) (Ref rn8 2) + linkNodes (Ref rn6 2) (Ref rn9 1) + linkNodes (Ref rn7 2) (Ref rn9 2) + linkNodes r0 r10 + linkNodes r1 r11 + linkNodes r2 $ Ref rn8 0 + linkNodes r3 $ Ref rn9 0 + where + mk = Branch2BNode lvl1 opc + w1 = wrap fst + w2 = wrap snd + + wrap sel re' r4 = do + rn5 <- newNode $ const $ DupNode lvl0 re' () () () + rn6 <- newNode $ const $ DeadNode () + linkNodes (Ref rn5 $ sel (2, 1)) (Ref rn6 0) + linkNodes r4 $ Ref rn5 $ sel (1, 2) + pure $ Ref rn5 0 + + dupNames gop ltt rn3 rn4 idx (name, _) + = (name, (gop idx $ mkRef ltt rn3, gop idx $ mkRef ltt rn4)) + + shareRef :: (B.Name, B.Type) -> B.Operand + shareRef (name, t) = B.Reference t name +{-# INLINABLE shareBranch2B #-} + +sharePreaction + :: HasRewriter sig m + => (Renames -> Renames -> Renames) + -> (Renames -> Ref -> m Ref) -> (Renames -> Ref -> m Ref) + -> (Preaction -> () -> () -> INetF ()) + -> Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () +sharePreaction append w1 w2 mk lvl re nbs r0 r1 r2 = case sharePreaction' nbs of + Nothing -> copyIO2 lvl r0 r1 r2 mk renamePreaction re nbs + Just (name, sb) | null (B.bodyInstrs sb) -> do + let mkPreaction rn = SimplePreaction (mkName rn) sb + rn3 <- newNode $ \rn3 -> mk (mkPreaction rn3) () () + rn4 <- newNode $ \rn4 -> mk (mkPreaction rn4) () () + let re' = M.singleton name (mkRef t rn3, mkRef t rn4) + t = B.instrType $ B.bodyTerm sb + rn5 <- newNode $ const $ DupNode lvl (append re' re) () () () + r6 <- w1 re' $ Ref rn3 0 + r7 <- w2 re' $ Ref rn4 0 + linkNodes (Ref rn3 1) (Ref rn5 1) + linkNodes (Ref rn4 1) (Ref rn5 2) + linkNodes r0 r6 + linkNodes r1 r7 + linkNodes r2 $ Ref rn5 0 + Just (name, sb) -> do + let names = preactionNames nbs + extraArgs = sb ^.. B.bodyFreeRefs + args = M.assocs re + args' = uncurry (B.:=) + <$> (swap <$> extraArgs) + <> (second (B.opType . fst) <$> args) + rn3 <- newNode $ \rn3 -> RootNode (mkName rn3) args' () + let mkPreact sel rn = mkCall sel rn + mkCall sel rn = SimplePreaction (mkName rn) $ B.Body mempty + $ B.Call ltt (mkName rn3) + $ (<>) (uncurry B.Reference <$> extraArgs) + $ sel . snd <$> args + sb' = B.concatBody name sb $ B.Body mempty $ B.Pure sop + (sop, gop, ltt) = case names of + [] -> (B.Empty, const $ const B.Empty, B.IntType 0) + [name'] -> (shareRef name', const id, snd name') + _ -> (B.Tuple $ shareRef <$> names, mkGetElement + , B.TupleType $ snd <$> names) + rn4 <- newNode $ const $ IONode sb' () + rn5 <- newNode $ \rn5 -> mk (mkPreact fst rn5) () () + rn6 <- newNode $ \rn6 -> mk (mkPreact snd rn6) () () + let re' = M.fromList $ zipWith (dupNames gop ltt rn5 rn6) [0..] names + rn7 <- newNode $ const $ DupNode lvl (append re' re) () () () + r8 <- w1 re' (Ref rn5 0) + r9 <- w2 re' (Ref rn6 0) + linkNodes (Ref rn3 0) (Ref rn4 0) + linkNodes (Ref rn5 1) (Ref rn7 1) + linkNodes (Ref rn6 1) (Ref rn7 2) + linkNodes r0 r8 + linkNodes r1 r9 + linkNodes r2 $ Ref rn7 0 + where + dupNames gop ltt rn3 rn4 idx (name, _) + = (name, (gop idx $ mkRef ltt rn3, gop idx $ mkRef ltt rn4)) + + shareRef :: (B.Name, B.Type) -> B.Operand + shareRef (name, t) = B.Reference t name +{-# INLINABLE sharePreaction #-} + +sharePreaction' :: Preaction -> Maybe (B.Name, B.Body) +sharePreaction' (SimplePreaction name b) = pure (name, b) +sharePreaction' (BranchPreaction opc nb1 nb2) = pure (B.UnusedName + , B.Body mempty $ B.Branch opc (applyCont nb1 eb) (applyCont nb2 eb)) + where + eb = B.Body mempty $ B.Pure B.Empty +sharePreaction' (ConcatPreaction nb1 nb2) + = case (sharePreaction' nb1, sharePreaction' nb2) of + (Nothing, Nothing) -> Nothing + (Just (name1, b1), Nothing) -> Just (name1, b1) + (Nothing, Just (name2, b2)) -> Just (name2, b2) + (Just (name1, b1), Just (name2, b2)) + -> Just (name2, B.concatBody name1 b1 b2) +sharePreaction' EmptyPreaction = Nothing +{-# INLINABLE sharePreaction' #-} + +preactionNames :: Preaction -> [(B.Name, B.Type)] +preactionNames (SimplePreaction name b) = case name of + B.UnusedName -> [] + _ -> case B.instrType $ B.bodyTerm b of + B.IntType 0 -> [] + t -> [(name, t)] +preactionNames (BranchPreaction _ nb1 nb2) + = preactionNames nb1 <> preactionNames nb2 +preactionNames (ConcatPreaction nb1 nb2) + = preactionNames nb1 <> preactionNames nb2 +preactionNames EmptyPreaction = [] +{-# INLINABLE preactionNames #-} + +mkLambda :: HasRewriter sig m => Ref -> (() -> () -> INetF ()) -> m () +mkLambda r0 mk1 = do + rn1 <- newNode $ const $ mk1 () () + rn2 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn1 0) (Ref rn2 1) + linkNodes (Ref rn1 1) (Ref rn2 2) + linkNodes r0 $ Ref rn2 0 +{-# INLINE mkLambda #-} + +applyCont :: Preaction -> B.Body -> B.Body +applyCont nbs = case nbs of + SimplePreaction name b -> B.concatBody name b + BranchPreaction op nb1 nb2 -> B.concatBody B.UnusedName + $ B.Body mempty $ B.Branch op (applyCont nb1 eb) (applyCont nb2 eb) + ConcatPreaction nb1 nb2 -> applyCont nb1 . applyCont nb2 + EmptyPreaction -> id + where + eb = B.Body mempty $ B.Pure B.Empty +{-# INLINABLE applyCont #-} + +renamePreaction :: M.Map B.Name B.Operand -> Preaction -> Preaction +renamePreaction re nbs = case nbs of + SimplePreaction name b + -> SimplePreaction name (B.renameBody re b) + BranchPreaction opc bt bf -> BranchPreaction + (B.renameOp re opc) (renamePreaction re bt) (renamePreaction re bf) + ConcatPreaction b1 b2 + -> ConcatPreaction (renamePreaction re b1) (renamePreaction re b2) + EmptyPreaction -> EmptyPreaction +{-# INLINABLE renamePreaction #-} + +mkName :: Int -> B.Name +mkName = B.Name . fromIntegral +{-# INLINE mkName #-} + +mkRef :: B.Type -> Int -> B.Operand +mkRef t = B.Reference t . mkName +{-# INLINE mkRef #-} + +mkSelect :: B.Operand -> B.Operand -> B.Operand -> B.Operand +mkSelect opc (B.Constant B.B1) (B.Constant B.B0) = opc +mkSelect opc opt opf + | opt == opf = opt + | otherwise = B.Select opc opt opf +{-# INLINABLE mkSelect #-} + +mkGetElement :: Int -> B.Operand -> B.Operand +mkGetElement idx (B.Tuple ops) = ops !! idx +mkGetElement idx opt = B.GetElement idx opt +{-# INLINABLE mkGetElement #-} + +type HasRewriter sig m = (Has (State INet) sig m, Has (State INetPairs) sig m + , Has (State INetSize) sig m) + +newtype INetSize = INetSize { unINetSize :: Int } + deriving newtype (Enum, Eq, Num, Ord) + +_INetSize :: Iso' INetSize Int +_INetSize = iso unINetSize INetSize +{-# INLINE _INetSize #-} + +-- TODO: See if removing the self-reference from the constructor is possible. +newNode :: HasRewriter sig m => (Int -> INetF ()) -> m Int +newNode mk = do + idx <- newNodeIndex + modify $ _INet . at idx ?~ (unsetRef <$ mk idx) + pure idx + where + unsetRef = Ref (-1) (-1) +{-# INLINE newNode #-} + +newNodeIndex :: Has (State INetSize) sig m => m Int +newNodeIndex = gets unINetSize <* modify @INetSize succ +{-# INLINE newNodeIndex #-} + +linkNodes :: HasRewriter sig m => Ref -> Ref -> m () +linkNodes r0 r1 = do + net <- get + modify @INet $ ix (refNode r0) . ix (refPort r0) .~ r1 + modify @INet $ ix (refNode r1) . ix (refPort r1) .~ r0 + modify $ _INetPairs %~ updatePairs net + where + updatePairs net + | refPort r0 == 0 && refPort r1 == 0 + = IS.insert (refNode r0) . IS.insert (refNode r1) + | refPort r0 == 0 = IS.delete (refNode r0) . IS.delete (deref r0) + | refPort r1 == 0 = IS.delete (refNode r1) . IS.delete (deref r1) + | otherwise = id + where + deref r2 = fromMaybe (-1) $ unINet net IM.!? refNode r2 + >>= (^? folded . to refNode) +{-# INLINE linkNodes #-} + +data TraceRewrite m a where + TraceRewrite + :: Ref -> Ref -> INetF Ref -> INetF Ref -> m r -> TraceRewrite m r + +traceRewrite + :: Has TraceRewrite sig m + => Ref -> Ref -> INetF Ref -> INetF Ref -> m r -> m r +traceRewrite r0 r1 n0 n1 cont = send $ TraceRewrite r0 r1 n0 n1 cont +{-# INLINE traceRewrite #-} + diff --git a/src/Language/Elemental/Parser.hs b/src/Language/Elemental/Parser.hs index a32fc21..7f5c50d 100644 --- a/src/Language/Elemental/Parser.hs +++ b/src/Language/Elemental/Parser.hs @@ -367,6 +367,9 @@ isIdentifierChar = \case '@' -> False '(' -> False ')' -> False + ';' -> False + '{' -> False + '}' -> False c -> isLetter c || isMark c || isNumber c || isPunctuation c || isSymbol c -- MTL boilerplate diff --git a/src/Language/Elemental/Pretty.hs b/src/Language/Elemental/Pretty.hs index bcf9bca..774abdc 100644 --- a/src/Language/Elemental/Pretty.hs +++ b/src/Language/Elemental/Pretty.hs @@ -10,7 +10,7 @@ module Language.Elemental.Pretty ( prettyDecl , prettyExpr , prettyType - , prettyLlvmType + , prettyBackendType , prettyNat -- * Unchecked , prettyUProgramF @@ -73,20 +73,21 @@ prettyExpr = flip $ \case Lam tx ey -> withPrec 0 $ "λ" <> prettyType 2 tx <+> prettyExpr 0 ey TypeLam ex -> withPrec 0 $ "Λ" <+> prettyExpr 0 ex Addr addr _ _ -> withPrec 3 $ braces $ "addr" <+> pretty addr - LlvmOperand lt _ -> withPrec 3 $ braces $ "op" <+> prettyLlvmType lt - LlvmIO lt _ -> withPrec 3 $ braces $ "io op" <+> prettyLlvmType lt + BackendOperand lt _ -> withPrec 3 $ braces $ "op" <+> prettyBackendType lt + BackendIO lt _ -> withPrec 3 $ braces $ "io op" <+> prettyBackendType lt + BackendPIO lt _ _ -> withPrec 3 $ braces $ "iop op" <+> prettyBackendType lt PureIO -> withPrec 3 $ braces "pureIO" BindIO -> withPrec 3 $ braces "bindIO" LoadPointer -> withPrec 3 $ braces "loadPointer" StorePointer -> withPrec 3 $ braces "storePointer" - Call _ _ ltargs ltret -> withPrec 3 $ braces $ "call" - <+> prettyLlvmType ltret <> parens (concatWith (surround ", ") - $ demoteList prettyLlvmType ltargs) + Call _ ltargs ltret -> withPrec 3 $ braces $ "call" + <+> prettyBackendType ltret <> parens (concatWith (surround ", ") + $ demoteList prettyBackendType ltargs) IsolateBit bidx size -> withPrec 3 $ braces $ "isolate" - <+> prettyNat bidx <+> prettyLlvmType (SLlvmInt size) + <+> prettyNat bidx <+> prettyBackendType (SBackendInt size) InsertBit size -> withPrec 3 $ braces - $ "insert" <+> prettyLlvmType (SLlvmInt size) - TestBit ex -> withPrec 3 $ braces $ "testBit" <+> prettyExpr 0 ex + $ "insert" <+> prettyBackendType (SBackendInt size) + TestBit -> withPrec 3 $ braces "testBit" -- | Prettyprints a type with the given precedence. prettyType :: Int -> SType tscope t -> Doc ann @@ -98,12 +99,12 @@ prettyType = flip $ \case SPointerType pk tx -> withPrec 1 $ case pk of SReadPointer -> "ReadPointer" <+> prettyType 2 tx SWritePointer -> "WritePointer" <+> prettyType 2 tx - SLlvmType lt -> withPrec 3 $ prettyLlvmType lt + SBackendType lt -> withPrec 3 $ prettyBackendType lt --- | Prettyprints an t'LlvmType'. -prettyLlvmType :: SLlvmType lt -> Doc ann -prettyLlvmType = \case - SLlvmInt size -> "i" <> prettyNat size +-- | Prettyprints a t'BackendType'. +prettyBackendType :: SBackendType lt -> Doc ann +prettyBackendType = \case + SBackendInt size -> "i" <> prettyNat size -- | Prettyprints a 'Nat'. prettyNat :: SNat nat -> Doc ann diff --git a/src/Language/Elemental/TypeCheck.hs b/src/Language/Elemental/TypeCheck.hs index eb5ee46..23e9fdf 100644 --- a/src/Language/Elemental/TypeCheck.hs +++ b/src/Language/Elemental/TypeCheck.hs @@ -18,7 +18,7 @@ module Language.Elemental.TypeCheck , unify , unify' , unifyPtrKind - , unifyLlvmType + , unifyBackendType , unifyNat , checkScope , checkForeignType @@ -212,22 +212,23 @@ unify' mismatch ta tb cont = case (ta, tb) of (SPointerType tapk tax, SPointerType tbpk tbx) -> unifyPtrKind (mismatch ta tb) tapk tbpk $ unify' mismatch tax tbx cont - (SLlvmType lta, SLlvmType ltb) - -> unifyLlvmType (mismatch ta tb) lta ltb cont + (SBackendType lta, SBackendType ltb) + -> unifyBackendType (mismatch ta tb) lta ltb cont _ -> mismatch ta tb -- | Attempts to unify two pointer kinds, producing a proof if they're equal. unifyPtrKind :: r -> SPointerKind exp -> SPointerKind act -> (exp ~ act => r) -> r unifyPtrKind mismatch apk bpk cont = case (apk, bpk) of - (SReadPointer, SReadPointer) -> cont - (SWritePointer, SWritePointer) -> cont - _ -> mismatch + (SReadPointer, SReadPointer) -> cont + (SWritePointer, SWritePointer) -> cont + _ -> mismatch --- | Attempts to unify two t'LlvmType', producing a proof if they're equal. -unifyLlvmType :: r -> SLlvmType exp -> SLlvmType act -> (exp ~ act => r) -> r -unifyLlvmType mismatch lta ltb cont = case (lta, ltb) of - (SLlvmInt sizea, SLlvmInt sizeb) -> unifyNat mismatch sizea sizeb cont +-- | Attempts to unify two t'BackendType', producing a proof if they're equal. +unifyBackendType + :: r -> SBackendType exp -> SBackendType act -> (exp ~ act => r) -> r +unifyBackendType mismatch lta ltb cont = case (lta, ltb) of + (SBackendInt sizea, SBackendInt sizeb) -> unifyNat mismatch sizea sizeb cont -- | Attempts to unify two natural numbers, producing a proof if they're equal. unifyNat :: r -> SNat exp -> SNat act -> (exp ~ act => r) -> r diff --git a/test/Gen.hs b/test/Gen.hs index 1d7ce8e..fd09f1c 100644 --- a/test/Gen.hs +++ b/test/Gen.hs @@ -77,7 +77,8 @@ instance Eq SomeType where (SIOType tax, SIOType tbx) -> SomeType tax == SomeType tbx (SPointerType pka tax, SPointerType pkb tbx) -> unifyPtrKind False pka pkb $ SomeType tax == SomeType tbx - (SLlvmType lta, SLlvmType ltb) -> unifyLlvmType False lta ltb True + (SBackendType lta, SBackendType ltb) + -> unifyBackendType False lta ltb True _ -> False genPSubexpr :: MonadGen m => PExpr -> m PExpr @@ -169,7 +170,7 @@ genTypedExpr tscope scope t = orVar $ case t of <$> genTypedExpr (SSucc tscope) (sIncrementAll tscope SZero scope) tx SIOType _ -> Gen.discard SPointerType _ _ -> Gen.discard - SLlvmType _ -> Gen.discard + SBackendType _ -> Gen.discard where orVar :: m (Expr tscope scope t) -> m (Expr tscope scope t) orVar m = Gen.choice [m, findVar scope $ pure . Var] @@ -250,8 +251,9 @@ genMarshallableRetType cont = Gen.choice , genMarshallableType cont ] -genLlvmType :: forall m r. MonadGen m => (forall lt. SLlvmType lt -> m r) -> m r -genLlvmType cont = genNat sup $ cont . SLlvmInt +genBackendType + :: forall m r. MonadGen m => (forall lt. SBackendType lt -> m r) -> m r +genBackendType cont = genNat sup $ cont . SBackendInt where sup = SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc $ SSucc SZero diff --git a/test/Golden.hs b/test/Golden.hs index 33c1d67..a0742eb 100644 --- a/test/Golden.hs +++ b/test/Golden.hs @@ -1,12 +1,27 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module Golden where -import Control.Algebra (run) +import Control.Algebra (Algebra(alg), Has, (:+:)(L, R), run) +import Control.Carrier.Reader (ReaderC(ReaderC), runReader) +import Control.Carrier.State.Church (State, evalState, get, gets, modify) +import Control.Lens (Iso', iso, ix, (^?), (%~)) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL +import Data.Foldable (traverse_) import Data.Functor.Identity (Identity) +import Data.IntMap qualified as IM +import Data.IntSet qualified as IS import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Text.Short qualified as TS @@ -17,14 +32,22 @@ import LLVM.Module (File(File), moduleLLVMAssembly, withModuleFromAST, writeLLVMAssemblyToFile) import LLVM.PassManager (runPassManager, withPassManager) import LLVM.PassManager qualified as LLVM.Pass -import Prettyprinter (pretty, (<+>)) +import Prettyprinter + ( Doc, PageWidth(Unbounded) + , defaultLayoutOptions, layoutPageWidth, layoutPretty, line, pretty, (<+>) + ) +import Prettyprinter.Render.Text (renderIO) import System.FilePath (replaceExtension, takeBaseName) -import System.IO (IOMode(WriteMode), withFile) +import System.IO + ( BufferMode(NoBuffering), Handle, IOMode(WriteMode) + , hPrint, hPutStrLn, hSetBuffering, withFile + ) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Golden (findByExtension, goldenVsString) import Text.Megaparsec (MonadParsec(eof), errorBundlePretty, runParser) -import Language.Elemental +import Language.Elemental hiding (L, R) +import Language.Elemental.Backend.LLVM goldenTests :: IO TestTree @@ -37,38 +60,62 @@ goldenTests = do ] compileFile :: FilePath -> IO BSL.ByteString -compileFile file = do - src <- TE.decodeUtf8 <$> BS.readFile file - uprog <- parseSource src +compileFile file = runGolden $ \lh -> do + uprog <- liftIO $ do + hSetBuffering lh NoBuffering + src <- TE.decodeUtf8 <$> BS.readFile file + parseSource src let prog = printDiags $ tcProgram uprog - llvmDefs = emitProgram prog + liftIO $ hPutStrLn lh "Emitting" + exts <- emitProgram prog + graph <- get @INet + liftIO $ hPutStrLn lh "Interpreting" + gen <- compileINet exts + graph' <- get @INet + liftIO $ hPutStrLn lh "Translating" + let llvmDefs = compileProgram gen llvm = defaultModule { moduleSourceFileName = TS.toShortByteString $ TS.fromString file , moduleDefinitions = llvmDefs } - withContext $ \ctx -> withModuleFromAST ctx llvm - $ \m -> withPassManager passes $ \pm -> do - -- writeLLVMAssemblyToFile doesn't truncate the file if it exists. - () <- withFile (replaceExtension file ".ll") WriteMode mempty - writeLLVMAssemblyToFile (File $ replaceExtension file ".ll") m - verify m - {- - Run -O3 multiple times because llvm-hs doesn't allow us to build - our own custom pipeline with all the passes we need and once - isn't enough. - -} - _ <- runPassManager pm m - _ <- runPassManager pm m - _ <- runPassManager pm m - _ <- runPassManager pm m - _ <- runPassManager pm m - BSL.fromStrict <$> moduleLLVMAssembly m + liftIO $ do + withFile (replaceExtension file ".inet") WriteMode + $ \h -> hPutDoc h $ pretty graph + withFile (replaceExtension file ".opt.inet") WriteMode + $ \h -> hPutDoc h $ pretty graph' + withFile (replaceExtension file ".hl") WriteMode + $ \h -> hPutDoc h $ pretty gen + withContext $ \ctx -> withModuleFromAST ctx llvm + $ \m -> withPassManager passes $ \pm -> do + -- writeLLVMAssemblyToFile doesn't truncate the file. + () <- withFile (replaceExtension file ".ll") WriteMode mempty + writeLLVMAssemblyToFile (File $ replaceExtension file ".ll") m + verify m + {- + Run -O3 multiple times because llvm-hs doesn't allow us to + build our own custom pipeline with all the passes we need + and once isn't enough. + -} + _ <- runPassManager pm m + _ <- runPassManager pm m + _ <- runPassManager pm m + _ <- runPassManager pm m + _ <- runPassManager pm m + BSL.fromStrict <$> moduleLLVMAssembly m where parseSource :: T.Text -> IO PProgram parseSource src = case runParser (mkParser $ pProgram <* eof) file src of Left errors -> error $ errorBundlePretty errors Right uprog -> pure uprog + runGolden m = withFile (replaceExtension file ".log") WriteMode $ \lh + -> evalState @INet mempty + $ evalState @INetPairs mempty + $ evalState @INetSize 0 + $ evalState @Count 0 + $ runReader @Level 0 + $ runTraceRewrite <*> m $ lh + printDiags :: DiagnosisC Diagnostic Identity a -> a printDiags = run . runDiagnosis pure (printDiag "Error") (printDiag "Warning") @@ -88,3 +135,102 @@ passes = LLVM.Pass.CuratedPassSetSpec , LLVM.Pass.targetLibraryInfo = Nothing , LLVM.Pass.targetMachine = Nothing } + +newtype TraceRewriteC m a = TraceRewriteC (Handle -> m a) + deriving (Functor, Applicative, Monad, MonadIO) via ReaderC Handle m + +runTraceRewrite :: Handle -> TraceRewriteC m a -> m a +runTraceRewrite h (TraceRewriteC f) = f h +{-# INLINE runTraceRewrite #-} + +instance (MonadIO m, Has (State Count) sig m, Has (State INet) sig m + , Has (State INetPairs) sig m, Has (State INetSize) sig m) + => Algebra (TraceRewrite :+: sig) (TraceRewriteC m) + where + alg hdl sig ctx = TraceRewriteC $ \h -> case sig of + L (TraceRewrite _ _ n0 n1 cont) -> do + size0 <- gets unINetSize + r <- runTraceRewrite h . hdl $ cont <$ ctx + lint size0 n0 n1 + modify $ _Count %~ succ + case (n0, n1) of + (AppNode {}, _) -> pure r + (_, AppNode {}) -> pure r + (DupNode {}, _) -> pure r + (_, DupNode {}) -> pure r + (DeadNode {}, _) -> pure r + (_, DeadNode {}) -> pure r + (BoxNode {}, _) -> pure r + (_, BoxNode {}) -> pure r + _ -> do + count <- gets unCount + netSize <- gets (IM.size . unINet) + pairsSize <- gets (IS.size . unINetPairs) + liftIO $ hPrint h + $ pretty count + <+> pretty netSize + <+> pretty pairsSize + <+> prettyHead n0 + <+> prettyHead n1 + pure r + R other -> alg (runTraceRewrite h . hdl) other ctx + where + lint :: Has (State INet) sig m => Int -> INetF Ref -> INetF Ref -> m () + lint size n0 n1 + = gets unINet >>= (traverse_ . traverse) lintRef + where + lintRef :: Has (State INet) sig m => Ref -> m () + lintRef (Ref (-1) (-1)) = abort "uninitialised ref" + lintRef r3 = do + net <- get @INet + case net ^? ix (refNode r3) of + Nothing -> abort $ "missing node:" <+> pretty r3 + Just n4 -> case n4 ^? ix (refPort r3) of + Nothing -> abort $ "missing port:" <+> pretty r3 + Just _ -> pure () + + abort :: Has (State INet) sig m => Doc ann -> m a + abort msg = do + net <- get @INet + error . show $ "lint:" <+> msg + <> line <> "Size before reduction was" <+> pretty size + <> line <> "Node 1: " <> pretty n0 + <> line <> "Node 2: " <> pretty n1 + <> line <> pretty net + + prettyHead :: INetF a -> Doc ann + prettyHead n0 = case n0 of + LamNode {} -> "Lam" + AppNode {} -> "App" + DupNode {} -> "Dup" + DeadNode {} -> "Dead" + BoxNode {} -> "Box" + RootNode {} -> "Root" + OperandNode {} -> "Operand" + OperandPNode {} -> "OperandP" + IONode {} -> "IO" + IOPNode {} -> "IOP" + IOContNode {} -> "IOCont" + Pure0Node {} -> "Pure0" + Bind0Node {} -> "Bind0" + Bind1Node {} -> "Bind1" + Branch0Node {} -> "Branch0" + Branch1Node {} -> "Branch1" + Branch2BNode {} -> "Branch2B" + Branch2PNode {} -> "Branch2P" + {-# INLINE alg #-} + +newtype Count = Count { unCount :: Int } + deriving newtype (Eq, Num, Ord) + +_Count :: Iso' Count Int +_Count = iso unCount Count +{-# INLINE _Count #-} + +hPutDoc :: Handle -> Doc ann -> IO () +hPutDoc h doc = renderIO h $ layoutPretty opts doc + where + opts = defaultLayoutOptions + { layoutPageWidth = Unbounded + } + diff --git a/test/Golden/.gitignore b/test/Golden/.gitignore index 5210c4e..5363b53 100644 --- a/test/Golden/.gitignore +++ b/test/Golden/.gitignore @@ -1,4 +1,6 @@ *.log +*.inet +*.hl *.ll # Don't ignore optimised outputs; we need them for golden tests !*.opt.ll diff --git a/test/Golden/CataStaticDouble.elem b/test/Golden/CataStaticDouble.elem new file mode 100644 index 0000000..f360087 --- /dev/null +++ b/test/Golden/CataStaticDouble.elem @@ -0,0 +1,23 @@ +-- CataStatic but using a doubling function instead of repeating succ. + +foreign export "main" main : IO (∀ 0 → 0) + +main = count @(IO (∀ 0 → 0)) (λ(∀ 0 → (IO (∀ 0 → 0) → 0) → 0) + 0 @(IO (∀ 0 → 0)) + (pureIO @(∀ 0 → 0) (Λ λ0 0)) + (λ(IO (∀ 0 → 0)) bindIO @(∀ 0 → 0) 0 @(∀ 0 → 0) (λ(∀ 0 → 0) c_dothing)) + ) + +count = double (double (succ zero)) + +double = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (λ(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 1 succ) + +zero = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 1) +succ = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (3 @1 2)) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +foreign import c_dothing "dothing" : IO (∀ 0 → 0) diff --git a/test/Golden/CataStaticDouble.opt.ll b/test/Golden/CataStaticDouble.opt.ll new file mode 100644 index 0000000..00dcf4c --- /dev/null +++ b/test/Golden/CataStaticDouble.opt.ll @@ -0,0 +1,12 @@ +; ModuleID = '' +source_filename = "test/Golden/CataStaticDouble.elem" + +declare void @dothing() local_unnamed_addr + +define void @main() local_unnamed_addr { + tail call void @dothing() + tail call void @dothing() + tail call void @dothing() + tail call void @dothing() + ret void +} diff --git a/test/Golden/CataStaticTwice.elem b/test/Golden/CataStaticTwice.elem new file mode 100644 index 0000000..4ed27a8 --- /dev/null +++ b/test/Golden/CataStaticTwice.elem @@ -0,0 +1,22 @@ +-- CataStatic but using repeated composition instead of repeating succ. + +foreign export "main" main : IO (∀ 0 → 0) + +main = count @(IO (∀ 0 → 0)) (λ(∀ 0 → (IO (∀ 0 → 0) → 0) → 0) + 0 @(IO (∀ 0 → 0)) + (pureIO @(∀ 0 → 0) (Λ λ0 0)) + (λ(IO (∀ 0 → 0)) bindIO @(∀ 0 → 0) 0 @(∀ 0 → 0) (λ(∀ 0 → 0) c_dothing)) + ) + +count = twice (twice (twice succ)) zero + +twice = λ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → ∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 1 (1 0) + +zero = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 1) +succ = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (3 @1 2)) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +foreign import c_dothing "dothing" : IO (∀ 0 → 0) diff --git a/test/Golden/CataStaticTwice.opt.ll b/test/Golden/CataStaticTwice.opt.ll new file mode 100644 index 0000000..3d4c16c --- /dev/null +++ b/test/Golden/CataStaticTwice.opt.ll @@ -0,0 +1,16 @@ +; ModuleID = '' +source_filename = "test/Golden/CataStaticTwice.elem" + +declare void @dothing() local_unnamed_addr + +define void @main() local_unnamed_addr { + tail call void @dothing() + tail call void @dothing() + tail call void @dothing() + tail call void @dothing() + tail call void @dothing() + tail call void @dothing() + tail call void @dothing() + tail call void @dothing() + ret void +} diff --git a/test/Golden/FunctionInIO.opt.ll b/test/Golden/FunctionInIO.opt.ll index af3a468..990503b 100644 --- a/test/Golden/FunctionInIO.opt.ll +++ b/test/Golden/FunctionInIO.opt.ll @@ -3,6 +3,12 @@ source_filename = "test/Golden/FunctionInIO.elem" declare i1 @getbit() local_unnamed_addr +; Function Attrs: norecurse nounwind readnone +define i1 @main(i1) local_unnamed_addr #0 { + %not. = xor i1 %0, true + ret i1 %not. +} + define i1 @main2() local_unnamed_addr { %1 = tail call i1 @getbit() %2 = tail call i1 @getbit() @@ -10,10 +16,4 @@ define i1 @main2() local_unnamed_addr { ret i1 %3 } -; Function Attrs: norecurse nounwind readnone -define i1 @main(i1) local_unnamed_addr #0 { - %not. = xor i1 %0, true - ret i1 %not. -} - attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/IOInIO.elem b/test/Golden/IOInIO.elem new file mode 100644 index 0000000..916ff0d --- /dev/null +++ b/test/Golden/IOInIO.elem @@ -0,0 +1,11 @@ +foreign export "main" main : IO (∀ 0 → 0 → 0) + +foreign import c_getbit "getbit" : IO (∀ 0 → 0 → 0) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +main = bindIO + @(IO (∀ 0 → 0 → 0)) (pureIO @(IO (∀ 0 → 0 → 0)) c_getbit) + @(∀ 0 → 0 → 0) (λ(IO (∀ 0 → 0 → 0)) 0) + diff --git a/test/Golden/IOInIO.opt.ll b/test/Golden/IOInIO.opt.ll new file mode 100644 index 0000000..0d6ad95 --- /dev/null +++ b/test/Golden/IOInIO.opt.ll @@ -0,0 +1,9 @@ +; ModuleID = '' +source_filename = "test/Golden/IOInIO.elem" + +declare i1 @getbit() local_unnamed_addr + +define i1 @main() local_unnamed_addr { + %1 = tail call i1 @getbit() + ret i1 %1 +} diff --git a/test/Golden/NestedBranch.elem b/test/Golden/NestedBranch.elem new file mode 100644 index 0000000..31493a9 --- /dev/null +++ b/test/Golden/NestedBranch.elem @@ -0,0 +1,21 @@ +foreign export "main" main + : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + → IO (∀ 0 → 0) + +foreign import c_dothing "dothing" : IO (∀ 0 → 0) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +main = abort_if_nonzero c_dothing + +abort_if_nonzero = λ(IO (∀ 0 → 0)) λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + 0 @(∀ 0 → 0 → 0) (λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) + λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) + or 0 (or 1 (or 2 (or 3 (or 4 (or 5 (or 6 7)))))) + ) @(IO (∀ 0 → 0)) (pureIO @(∀ 0 → 0) (Λ λ0 0)) 1 + +or = λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) 1 @(∀ 0 → 0 → 0) t 0 + +t = Λ λ0 λ0 1 + diff --git a/test/Golden/NestedBranch.opt.ll b/test/Golden/NestedBranch.opt.ll new file mode 100644 index 0000000..45110ef --- /dev/null +++ b/test/Golden/NestedBranch.opt.ll @@ -0,0 +1,16 @@ +; ModuleID = '' +source_filename = "test/Golden/NestedBranch.elem" + +declare void @dothing() local_unnamed_addr + +define void @main(i8) local_unnamed_addr { + %2 = icmp eq i8 %0, 0 + br i1 %2, label %3, label %4 + +3: ; preds = %1 + tail call void @dothing() + br label %4 + +4: ; preds = %3, %1 + ret void +} diff --git a/test/Golden/NestedBranch2.elem b/test/Golden/NestedBranch2.elem new file mode 100644 index 0000000..c94001b --- /dev/null +++ b/test/Golden/NestedBranch2.elem @@ -0,0 +1,25 @@ +foreign export "main" main + : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + → IO (∀ 0 → 0) + +foreign import c_dothing "dothing" + : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + → IO (∀ 0 → 0) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +main = abort_if_null (λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) bindIO + @(∀ 0 → 0) (c_dothing 0) + @(∀ 0 → 0) (λ(∀ 0 → 0) (c_dothing 1))) + +abort_if_null = λ((∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) → IO (∀ 0 → 0)) + λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + 0 @(∀ 0 → 0 → 0) (λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) + or 0 (or 1 (or 2 3)) + ) @(IO (∀ 0 → 0)) (1 0) (pureIO @(∀ 0 → 0) (Λ λ0 0)) + +or = λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) 1 @(∀ 0 → 0 → 0) t 0 + +t = Λ λ0 λ0 1 + diff --git a/test/Golden/NestedBranch2.opt.ll b/test/Golden/NestedBranch2.opt.ll new file mode 100644 index 0000000..f3f6341 --- /dev/null +++ b/test/Golden/NestedBranch2.opt.ll @@ -0,0 +1,22 @@ +; ModuleID = '' +source_filename = "test/Golden/NestedBranch2.elem" + +declare void @dothing(i4) local_unnamed_addr + +define private fastcc void @"6391"(i4) unnamed_addr { + tail call void @dothing(i4 %0) + tail call void @dothing(i4 %0) + ret void +} + +define void @main(i4) local_unnamed_addr { + %2 = icmp eq i4 %0, 0 + br i1 %2, label %3, label %.sink.split + +.sink.split: ; preds = %1 + tail call fastcc void @"6391"(i4 %0) + br label %3 + +3: ; preds = %1, %.sink.split + ret void +} diff --git a/test/Golden/ParserQuirks.opt.ll b/test/Golden/ParserQuirks.opt.ll new file mode 100644 index 0000000..e69de29 diff --git a/test/Golden/SelfReference.elem b/test/Golden/SelfReference.elem new file mode 100644 index 0000000..6294070 --- /dev/null +++ b/test/Golden/SelfReference.elem @@ -0,0 +1,15 @@ +-- Minimal program that can't be optimally evaluated without any book-keeping. + +foreign export "main" main : IO (∀ 0 → 0) + +foreign primitive pureIO : ∀ 0 → IO 0 + +main = pureIO @(∀ 0 → 0) (id @(∀ 0 → 0) id) + +-- Both t and f cause problems here. +id = Λ λ0 t @0 0 0 +-- id = Λ λ0 f @0 0 0 + +t = Λ λ0 λ0 1 +-- f = Λ λ0 λ0 0 + diff --git a/test/Golden/SelfReference.opt.ll b/test/Golden/SelfReference.opt.ll new file mode 100644 index 0000000..1cd9fdd --- /dev/null +++ b/test/Golden/SelfReference.opt.ll @@ -0,0 +1,9 @@ +; ModuleID = '' +source_filename = "test/Golden/SelfReference.elem" + +; Function Attrs: norecurse nounwind readnone +define void @main() local_unnamed_addr #0 { + ret void +} + +attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/ShareBindCont.elem b/test/Golden/ShareBindCont.elem new file mode 100644 index 0000000..3f1bd60 --- /dev/null +++ b/test/Golden/ShareBindCont.elem @@ -0,0 +1,17 @@ +foreign export "main1" main1 : IO (∀ 0 → 0 → 0) +foreign export "main2" main2 : IO (∀ 0 → 0 → 0) + +foreign import c_getbit "getbit" : IO (∀ 0 → 0 → 0) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +main1 = shared (pureIO @(∀ 0 → 0 → 0)) +main2 = shared (λ(∀ 0 → 0 → 0) pureIO @(∀ 0 → 0 → 0) (not 0)) + +shared = λ((∀ 0 → 0 → 0) → IO (∀ 0 → 0 → 0)) bindIO + @(∀ 0 → 0 → 0) c_getbit + @(∀ 0 → 0 → 0) 0 + +not = λ(∀ 0 → 0 → 0) Λ λ0 λ0 2 @0 0 1 + diff --git a/test/Golden/ShareBindCont.opt.ll b/test/Golden/ShareBindCont.opt.ll new file mode 100644 index 0000000..5911f9a --- /dev/null +++ b/test/Golden/ShareBindCont.opt.ll @@ -0,0 +1,15 @@ +; ModuleID = '' +source_filename = "test/Golden/ShareBindCont.elem" + +declare i1 @getbit() local_unnamed_addr + +define i1 @main1() local_unnamed_addr { + %1 = tail call i1 @getbit() + ret i1 %1 +} + +define i1 @main2() local_unnamed_addr { + %1 = tail call i1 @getbit() + %not. = xor i1 %1, true + ret i1 %not. +} diff --git a/test/Golden/ShareFunction.elem b/test/Golden/ShareFunction.elem new file mode 100644 index 0000000..fb135d9 --- /dev/null +++ b/test/Golden/ShareFunction.elem @@ -0,0 +1,13 @@ +foreign export "value" pureValue : IO (∀ 0 → 0) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +pureValue = bindIO @(∀ 0 → 0) (pureIO @(∀ 0 → 0) value) + @(∀ 0 → 0) (λ(∀ 0 → 0) pureIO @(∀ 0 → 0) 0) + +value = Λ λ0 0 + +-- This assignment causes duplication, which can break the rewriting. +break = value + diff --git a/test/Golden/ShareFunction.opt.ll b/test/Golden/ShareFunction.opt.ll new file mode 100644 index 0000000..10b3b20 --- /dev/null +++ b/test/Golden/ShareFunction.opt.ll @@ -0,0 +1,9 @@ +; ModuleID = '' +source_filename = "test/Golden/ShareFunction.elem" + +; Function Attrs: norecurse nounwind readnone +define void @value() local_unnamed_addr #0 { + ret void +} + +attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/ShareFunction2.elem b/test/Golden/ShareFunction2.elem new file mode 100644 index 0000000..fbc14dd --- /dev/null +++ b/test/Golden/ShareFunction2.elem @@ -0,0 +1,10 @@ +-- Minimal test case that breaks when there are no duplication tags. + +foreign primitive pureIO : ∀ 0 → IO 0 + +foreign export "value" pureValue : IO (∀ 0 → 0) + +pureValue = pureIO @(∀ 0 → 0) (Λ λ0 0) + +break = pureValue + diff --git a/test/Golden/ShareFunction2.opt.ll b/test/Golden/ShareFunction2.opt.ll new file mode 100644 index 0000000..885283b --- /dev/null +++ b/test/Golden/ShareFunction2.opt.ll @@ -0,0 +1,9 @@ +; ModuleID = '' +source_filename = "test/Golden/ShareFunction2.elem" + +; Function Attrs: norecurse nounwind readnone +define void @value() local_unnamed_addr #0 { + ret void +} + +attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/ShareIO.elem b/test/Golden/ShareIO.elem new file mode 100644 index 0000000..f6eaffb --- /dev/null +++ b/test/Golden/ShareIO.elem @@ -0,0 +1,30 @@ +foreign export "main1" main1 : IO (∀ 0 → 0) +foreign export "main2" main2 : IO (∀ 0 → 0) + +foreign import c_getbit "getbit" : IO (∀ 0 → 0 → 0) +foreign import c_putbit "putbit" : (∀ 0 → 0 → 0) → IO (∀ 0 → 0) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +main1 = bindIO + @(∀ 0 → 0 → 0) getValue + @(∀ 0 → 0) c_putbit + +-- main2 = main1 +main2 = bindIO + @(∀ 0 → 0 → 0) getValue + @(∀ 0 → 0) c_putbit + +-- This is a fairly tricky sequence of binds to duplicate. +getValue = bindIO + @(∀ 0 → 0 → 0) c_getbit + @(∀ 0 → 0 → 0) (λ(∀ 0 → 0 → 0) + bindIO + @(∀ 0 → 0 → 0) c_getbit + @(∀ 0 → 0 → 0) (λ(∀ 0 → 0 → 0) pureIO @(∀ 0 → 0 → 0) (xor 0 1))) + +not = λ(∀ 0 → 0 → 0) Λ λ0 λ0 2 @0 0 1 + +xor = λ(∀ 0 → 0 → 0) 0 @((∀ 0 → 0 → 0) → ∀ 0 → 0 → 0) not (λ(∀ 0 → 0 → 0) 0) + diff --git a/test/Golden/ShareIO.opt.ll b/test/Golden/ShareIO.opt.ll new file mode 100644 index 0000000..ced7054 --- /dev/null +++ b/test/Golden/ShareIO.opt.ll @@ -0,0 +1,32 @@ +; ModuleID = '' +source_filename = "test/Golden/ShareIO.elem" + +declare void @putbit(i1) local_unnamed_addr + +declare i1 @getbit() local_unnamed_addr + +define private fastcc { i1, i1 } @"2485"() unnamed_addr { + %1 = tail call i1 @getbit() + %2 = tail call i1 @getbit() + %3 = insertvalue { i1, i1 } zeroinitializer, i1 %2, 1 + %4 = insertvalue { i1, i1 } %3, i1 %1, 0 + ret { i1, i1 } %4 +} + +define void @main1() local_unnamed_addr { + %1 = tail call fastcc { i1, i1 } @"2485"() + %2 = extractvalue { i1, i1 } %1, 1 + %3 = extractvalue { i1, i1 } %1, 0 + %4 = xor i1 %3, %2 + tail call void @putbit(i1 %4) + ret void +} + +define void @main2() local_unnamed_addr { + %1 = tail call fastcc { i1, i1 } @"2485"() + %2 = extractvalue { i1, i1 } %1, 1 + %3 = extractvalue { i1, i1 } %1, 0 + %4 = xor i1 %3, %2 + tail call void @putbit(i1 %4) + ret void +} diff --git a/test/Golden/SimpleArgs.opt.ll b/test/Golden/SimpleArgs.opt.ll index d884c87..00ecb3a 100644 --- a/test/Golden/SimpleArgs.opt.ll +++ b/test/Golden/SimpleArgs.opt.ll @@ -2,13 +2,13 @@ source_filename = "test/Golden/SimpleArgs.elem" ; Function Attrs: norecurse nounwind readnone -define i1 @snd(i1, i1 returned) local_unnamed_addr #0 { - ret i1 %1 +define i1 @main(i1 returned) local_unnamed_addr #0 { + ret i1 %0 } ; Function Attrs: norecurse nounwind readnone -define i1 @main(i1 returned) local_unnamed_addr #0 { - ret i1 %0 +define i1 @snd(i1, i1 returned) local_unnamed_addr #0 { + ret i1 %1 } attributes #0 = { norecurse nounwind readnone } diff --git a/test/Main.hs b/test/Main.hs index dcea660..b690d11 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -27,4 +27,5 @@ tests = do ] where timeout :: Timeout - timeout = mkTimeout 1000000 -- 1s + timeout = mkTimeout 5000000 -- 5s + diff --git a/test/Pretty.hs b/test/Pretty.hs index 23f7878..6fc8f66 100644 --- a/test/Pretty.hs +++ b/test/Pretty.hs @@ -46,8 +46,11 @@ propParseDecl = property $ do propParseUProgram :: Property propParseUProgram = property $ do program <- forAllWith (show . prettyUProgram) $ genUProgram 5 5 - tripping' program enc dec + tripping' show1 T.unpack show3 program enc dec where + show1 = show . prettyUProgram + show3 = either id show1 + enc :: UProgram -> T.Text enc = renderStrict . layoutPretty defaultLayoutOptions . prettyUProgram diff --git a/test/Util.hs b/test/Util.hs index 2e70ae8..279dcf7 100644 --- a/test/Util.hs +++ b/test/Util.hs @@ -7,6 +7,7 @@ import Control.Monad (unless) import Data.Bifunctor (Bifunctor, first) import Data.Fix (Fix(Fix), foldFix, unFix) import Hedgehog +import Hedgehog.Internal.Property (failWith) import Language.Elemental @@ -26,10 +27,20 @@ stripType = foldFix $ Fix . sndP1 (===) :: (Eq a, MonadTest m) => a -> a -> m () x === y = unless (x == y) failure +-- Hedgehog's tripping requires 'Show' instances. tripping' :: (Eq (f a), Applicative f, MonadTest m) - => a -> (a -> b) -> (b -> f a) -> m () -tripping' x enc dec = if pure x == my then pure () else failure + => (a -> String) -> (b -> String) -> (f a -> String) + -> a -> (a -> b) -> (b -> f a) -> m () +tripping' show1 show2 show3 x enc dec + = if pure x == my then pure () else failWith Nothing $ unlines + [ "━━━ Original ━━━" + , show1 x + , "━━━ Intermediate ━━━" + , show2 i + , "━━━ Roundtrip ━━━" + , show3 my + ] where i = enc x my = dec i From fa5e1c1f1553df32305d3b091d3d2d26b84abeda Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Wed, 27 Apr 2022 06:51:20 +0100 Subject: [PATCH 02/17] Avoid duplicate arguments when sharing Previously, sharing would generate as many arguments as there were references. Often, most of them are duplicates. --- src/Language/Elemental/InteractionNet.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 8b220f6..75b39bb 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -76,6 +76,7 @@ import Data.DList (DList, toList) import Data.Foldable (find) import Data.IntMap.Strict qualified as IM import Data.IntSet qualified as IS +import Data.List (nub) import Data.Map.Lazy qualified as M import Data.Maybe (fromMaybe) import Data.Tuple (swap) @@ -778,7 +779,7 @@ shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 = case sharePreaction' nbt of linkNodes r3 $ Ref rn7 0 Just (name, sb) -> do let names = preactionNames nbt - extraArgs = sb ^.. B.bodyFreeRefs + extraArgs = nub $ sb ^.. B.bodyFreeRefs args = M.assocs re args' = uncurry (B.:=) <$> (swap <$> extraArgs) @@ -855,7 +856,7 @@ sharePreaction append w1 w2 mk lvl re nbs r0 r1 r2 = case sharePreaction' nbs of linkNodes r2 $ Ref rn5 0 Just (name, sb) -> do let names = preactionNames nbs - extraArgs = sb ^.. B.bodyFreeRefs + extraArgs = nub $ sb ^.. B.bodyFreeRefs args = M.assocs re args' = uncurry (B.:=) <$> (swap <$> extraArgs) From 1eecea83a21a5e84f6368fcd01ef88c96af09d70 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Thu, 28 Apr 2022 06:42:00 +0100 Subject: [PATCH 03/17] Fix bad bookkeeping due to Branch2P/Lam --- src/Language/Elemental/InteractionNet.hs | 175 +++++++++++++---------- test/Golden.hs | 57 ++------ test/Golden/NestedBranch2.opt.ll | 4 +- test/Golden/NestedBranch3.elem | 25 ++++ test/Golden/NestedBranch3.opt.ll | 22 +++ test/Golden/ShareIO.opt.ll | 6 +- test/Main.hs | 3 +- 7 files changed, 165 insertions(+), 127 deletions(-) create mode 100644 test/Golden/NestedBranch3.elem create mode 100644 test/Golden/NestedBranch3.opt.ll diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 75b39bb..e4e1cac 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -160,8 +160,10 @@ data INetF a | Branch1Node Level B.Operand a a -- | (IO a, a, IO a) | Branch2BNode Level B.Operand Preaction a a a - -- | (IO (a -> b), a, b, IO (a -> b)) - | Branch2PNode Level B.Operand a a a a + -- | (IO (a -> b), a -> b, IO (a -> b)) + | Branch2PNode Level B.Operand a a a + -- | (IO (a -> b), a -> b, a -> b) + | Branch3PNode Level B.Operand a a a deriving stock (Foldable, Functor, Traversable) instance Pretty a => Pretty (INetF a) where @@ -193,9 +195,12 @@ instance Pretty a => Pretty (INetF a) where pretty (Branch2BNode lvl opc nbt r0 r1 r2) = "Branch2B" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty opc <> nest 4 (line <> pretty nbt) - pretty (Branch2PNode lvl opc r0 r1 r2 r3) + pretty (Branch2PNode lvl opc r0 r1 r2) = "Branch2P" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 - <+> pretty r3 <+> pretty opc + <+> pretty opc + pretty (Branch3PNode lvl opc r0 r1 r2) + = "Branch3P" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 + <+> pretty opc instance Ixed (INetF a) where ix idx f = indexing traverse $ Indexed go @@ -306,8 +311,8 @@ reduce = try *> lintFinal reduceNode :: (HasRewriter sig m, Has (Writer (DList (B.Named B.Function))) sig m) => INetF Ref -> INetF Ref -> m () -reduceNode (AppNode _ r0 r1) (AppNode _ r2 r3) - = linkNodes r0 r1 *> linkNodes r2 r3 +-- reduceNode (AppNode _ r0 r1) (AppNode _ r2 r3) +-- = linkNodes r0 r2 *> linkNodes r1 r3 reduceNode (AppNode _ r0 r1) (LamNode _ r2 r3) = do rn4 <- newNode $ const $ BoxNode 0 () () rn5 <- newNode $ const $ BoxNode 0 () () @@ -324,6 +329,7 @@ reduceNode (LamNode _ r0 r1) (DupNode lvl re _ r2 r3) reduceNode n0@DupNode {} n1@LamNode {} = reduceNode n1 n0 reduceNode (DupNode lvl1 re1 _ r0 r1) (DupNode lvl2 re2 _ r2 r3) | lvl1 == lvl2 = linkNodes r0 r2 *> linkNodes r1 r3 + | lvl1 == 10 && lvl2 == 11 || lvl1 == 11 && lvl2 == 10 = linkNodes r0 r2 *> linkNodes r1 r3 | otherwise = commute2 (DupNode lvl1 re1) (DupNode lvl2 re2) r0 r1 r2 r3 reduceNode (AppNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@AppNode {} = reduceNode n1 n0 @@ -374,6 +380,14 @@ reduceNode (Pure0Node _ r0) (LamNode _ r1 r2) = do linkNodes r1 $ Ref rn4 1 linkNodes r2 $ Ref rn4 2 reduceNode n0@LamNode {} n1@Pure0Node {} = reduceNode n1 n0 +reduceNode (Pure0Node _ r0) (Branch3PNode lvl opc _ r1 r2) = do + rn3 <- newNode $ const $ IOContNode mempty () () + rn4 <- newNode $ const $ Branch3PNode lvl opc () () () + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes r0 $ Ref rn3 0 + linkNodes r1 $ Ref rn4 1 + linkNodes r2 $ Ref rn4 2 +reduceNode n0@Branch3PNode {} n1@Pure0Node {} = reduceNode n1 n0 reduceNode (Pure0Node _ r0) (OperandNode op _) = propagate1 r0 $ IONode $ B.Body mempty $ B.Pure op reduceNode n0@OperandNode {} n1@Pure0Node {} = reduceNode n1 n0 @@ -423,15 +437,39 @@ reduceNode n0@IOContNode {} n1@Bind1Node {} = reduceNode n1 n0 reduceNode (Branch0Node lvl _ r0) (OperandNode op _) = mkLambda r0 $ Branch1Node lvl op reduceNode n0@OperandNode {} n1@Branch0Node {} = reduceNode n1 n0 +reduceNode (Branch1Node lvl op _ r0) (AppNode _ r1 r2) = do + rn3 <- newNode $ const $ Branch2PNode lvl op () () () + rn4 <- newNode $ const $ LamNode () () () + rn5 <- newNode $ const $ AppNode () () () + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes (Ref rn3 1) (Ref rn5 0) + linkNodes (Ref rn3 2) (Ref rn4 2) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn5 1 + linkNodes r2 $ Ref rn5 2 +reduceNode n0@AppNode {} n1@Branch1Node {} = reduceNode n1 n0 reduceNode (Branch1Node lvl op _ r0) (LamNode _ r1 r2) = do - rn3 <- newNode $ const $ Branch2PNode lvl op () () () () + rn3 <- newNode $ const $ Branch2PNode lvl op () () () rn4 <- newNode $ const $ LamNode () () () + rn5 <- newNode $ const $ LamNode () () () linkNodes (Ref rn3 0) (Ref rn4 1) - linkNodes (Ref rn3 3) (Ref rn4 2) + linkNodes (Ref rn3 1) (Ref rn5 0) + linkNodes (Ref rn3 2) (Ref rn4 2) linkNodes r0 $ Ref rn4 0 - linkNodes r1 $ Ref rn3 1 - linkNodes r2 $ Ref rn3 2 + linkNodes r1 $ Ref rn5 1 + linkNodes r2 $ Ref rn5 2 reduceNode n0@LamNode {} n1@Branch1Node {} = reduceNode n1 n0 +reduceNode (Branch1Node lvl0 opc0 _ r0) (Branch3PNode lvl1 opc1 _ r1 r2) = do + rn3 <- newNode $ const $ Branch2PNode lvl0 opc0 () () () + rn4 <- newNode $ const $ LamNode () () () + rn5 <- newNode $ const $ Branch3PNode lvl1 opc1 () () () + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes (Ref rn3 1) (Ref rn5 0) + linkNodes (Ref rn3 2) (Ref rn4 2) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn5 1 + linkNodes r2 $ Ref rn5 2 +reduceNode n0@Branch3PNode {} n1@Branch1Node {} = reduceNode n1 n0 reduceNode (Branch1Node _ opc _ r0) (OperandNode opt _) = mkLambda r0 $ OperandPNode $ B.Partial (SSucc SZero) $ mkSelect opc opt reduceNode n0@OperandNode {} n1@Branch1Node {} = reduceNode n1 n0 @@ -454,20 +492,40 @@ reduceNode (Branch2BNode lvl op nbs1 _ r0 r1) (IOContNode nbs2 _ r2) = do linkNodes r1 $ Ref rn5 0 linkNodes r2 $ Ref rn4 1 reduceNode n0@IOContNode {} n1@Branch2BNode {} = reduceNode n1 n0 -reduceNode (Branch2PNode lvl opc _ r0 r1 r2) (LamNode _ r3 r4) = do - rn4 <- newNode $ const $ Branch1Node lvl opc () () - rn5 <- newNode $ const $ AppNode () () () - rn6 <- newNode $ const $ DupNode lvl mempty () () () - rn7 <- newNode $ const $ LamNode () () () - linkNodes (Ref rn4 1) (Ref rn5 0) - linkNodes (Ref rn5 2) (Ref rn7 2) - linkNodes (Ref rn6 0) (Ref rn7 1) - linkNodes r0 $ Ref rn6 1 +reduceNode (Branch2PNode lvl opc _ r0 r1) (LamNode _ r2 r3) = do + rn4 <- newNode $ const $ Branch3PNode lvl opc () () () + rn5 <- newNode $ const $ LamNode () () () + linkNodes (Ref rn4 2) (Ref rn5 0) + linkNodes r0 $ Ref rn4 1 linkNodes r1 $ Ref rn4 0 - linkNodes r2 $ Ref rn7 0 - linkNodes r3 $ Ref rn6 2 - linkNodes r4 $ Ref rn5 1 + linkNodes r2 $ Ref rn5 1 + linkNodes r3 $ Ref rn5 2 reduceNode n0@LamNode {} n1@Branch2PNode {} = reduceNode n1 n0 +reduceNode (Branch2PNode lvl0 opc0 _ r0 r1) (Branch3PNode lvl1 opc1 _ r2 r3) = do + rn4 <- newNode $ const $ Branch3PNode lvl0 opc0 () () () + rn5 <- newNode $ const $ Branch3PNode lvl1 opc1 () () () + linkNodes (Ref rn4 2) (Ref rn5 0) + linkNodes r0 $ Ref rn4 1 + linkNodes r1 $ Ref rn4 0 + linkNodes r2 $ Ref rn5 1 + linkNodes r3 $ Ref rn5 2 +reduceNode n0@Branch3PNode {} n1@Branch2PNode {} = reduceNode n1 n0 +reduceNode (Branch3PNode lvl opc _ r0 r1) (AppNode _ r2 r3) = do + rn4 <- newNode $ const $ AppNode () () () + rn5 <- newNode $ const $ AppNode () () () + rn6 <- newNode $ const $ DupNode 0 mempty () () () + rn7 <- newNode $ const $ Branch1Node lvl opc () () + rn8 <- newNode $ const $ AppNode () () () + linkNodes (Ref rn4 1) (Ref rn6 1) + linkNodes (Ref rn5 1) (Ref rn6 2) + linkNodes (Ref rn4 2) (Ref rn7 0) + linkNodes (Ref rn5 2) (Ref rn8 1) + linkNodes (Ref rn7 1) (Ref rn8 0) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn5 0 + linkNodes r2 $ Ref rn6 0 + linkNodes r3 $ Ref rn8 2 +reduceNode n0@AppNode {} n1@Branch3PNode {} = reduceNode n1 n0 -- FFI Duplication reduceNode (DupNode _ re _ r0 r1) (OperandNode op _) = copyIO1 r0 r1 OperandNode B.renameOp re op @@ -499,12 +557,18 @@ reduceNode n0@Branch1Node {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl0 re _ r0 r1) (Branch2BNode lvl1 opc nbt _ r2 r3) = shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 reduceNode n0@Branch2BNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch2PNode lvl1 op _ r2 r3 r4) - = commute3' (DupNode lvl0 re) +reduceNode (DupNode lvl0 re _ r0 r1) (Branch2PNode lvl1 op _ r2 r3) + = commute2' (DupNode lvl0 re) (DupNode lvl0 re) (Branch2PNode lvl1 $ B.renameOp (M.map fst re) op) (Branch2PNode lvl1 $ B.renameOp (M.map snd re) op) - r0 r1 r2 r3 r4 + r0 r1 r2 r3 reduceNode n0@Branch2PNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 re _ r0 r1) (Branch3PNode lvl1 op _ r2 r3) + = commute2' (DupNode lvl0 re) (DupNode lvl0 re) + (Branch3PNode lvl1 $ B.renameOp (M.map fst re) op) + (Branch3PNode lvl1 $ B.renameOp (M.map snd re) op) + r0 r1 r2 r3 +reduceNode n0@Branch3PNode {} n1@DupNode {} = reduceNode n1 n0 -- FFI Dead reduceNode (OperandNode _ _) (DeadNode _) = pure () reduceNode n0@DeadNode {} n1@OperandNode {} = reduceNode n1 n0 @@ -526,8 +590,8 @@ reduceNode (Branch1Node _ _ _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@Branch1Node {} = reduceNode n1 n0 reduceNode (Branch2BNode _ _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@Branch2BNode {} = reduceNode n1 n0 -reduceNode (Branch2PNode _ _ _ r0 r1 r2) (DeadNode _) - = propagate3 r0 r1 r2 DeadNode +reduceNode (Branch2PNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode (Branch3PNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@Branch2PNode {} = reduceNode n1 n0 -- FFI Book-keeping reduceNode (RootNode name args _) (BoxNode _ _ r0) @@ -570,11 +634,16 @@ reduceNode (Branch2BNode lvl0 opc nbt _ r0 r1) (BoxNode lvl1 _ r2) = commute1 (BoxNode lvl1) r0 r1 r2 reduceNode n0@BoxNode {} n1@Branch2BNode {} = reduceNode n1 n0 -reduceNode (Branch2PNode lvl0 opc _ r0 r1 r2) (BoxNode lvl1 _ r3) = commute1b +reduceNode (Branch2PNode lvl0 opc _ r0 r1) (BoxNode lvl1 _ r2) = commute1 (Branch2PNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc) (BoxNode lvl1) - r0 r1 r2 r3 + r0 r1 r2 reduceNode n0@BoxNode {} n1@Branch2PNode {} = reduceNode n1 n0 +reduceNode (Branch3PNode lvl0 opc _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (Branch3PNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc) + (BoxNode lvl1) + r0 r1 r2 +reduceNode n0@BoxNode {} n1@Branch3PNode {} = reduceNode n1 n0 reduceNode n0 n1 = error . show $ "unexpected node pairing" <> line <> pretty n0 <> line <> pretty n1 {-# INLINABLE reduceNode #-} @@ -614,24 +683,6 @@ commute1' mk1 mk2a mk2b r0 r1 r2 = do linkNodes r2 $ Ref rn5 0 {-# INLINABLE commute1' #-} -commute1b - :: HasRewriter sig m - => (() -> () -> () -> () -> INetF ()) -> (() -> () -> INetF ()) - -> Ref -> Ref -> Ref -> Ref -> m () -commute1b mk1 mk2 r0 r1 r2 r3 = do - rn4 <- newNode $ const $ mk2 () () - rn5 <- newNode $ const $ mk2 () () - rn6 <- newNode $ const $ mk2 () () - rn7 <- newNode $ const $ mk1 () () () () - linkNodes (Ref rn4 1) (Ref rn7 1) - linkNodes (Ref rn5 1) (Ref rn7 2) - linkNodes (Ref rn6 1) (Ref rn7 3) - linkNodes r0 $ Ref rn4 0 - linkNodes r1 $ Ref rn5 0 - linkNodes r2 $ Ref rn6 0 - linkNodes r3 $ Ref rn7 0 -{-# INLINABLE commute1b #-} - commute2 :: HasRewriter sig m => (() -> () -> () -> INetF ()) @@ -662,31 +713,6 @@ commute2' mk1a mk1b mk2a mk2b r0 r1 r2 r3 = do linkNodes r3 $ Ref rn5 0 {-# INLINABLE commute2' #-} -commute3' - :: HasRewriter sig m - => (() -> () -> () -> INetF ()) - -> (() -> () -> () -> () -> INetF ()) - -> (() -> () -> () -> () -> INetF ()) - -> Ref -> Ref -> Ref -> Ref -> Ref -> m () -commute3' mk1 mk2a mk2b r0 r1 r2 r3 r4 = do - rn5 <- newNode $ const $ mk1 () () () - rn6 <- newNode $ const $ mk1 () () () - rn7 <- newNode $ const $ mk1 () () () - rn8 <- newNode $ const $ mk2a () () () () - rn9 <- newNode $ const $ mk2b () () () () - linkNodes (Ref rn5 1) (Ref rn8 1) - linkNodes (Ref rn5 2) (Ref rn9 1) - linkNodes (Ref rn6 1) (Ref rn8 2) - linkNodes (Ref rn6 2) (Ref rn9 2) - linkNodes (Ref rn7 1) (Ref rn8 3) - linkNodes (Ref rn7 2) (Ref rn9 3) - linkNodes r0 $ Ref rn8 0 - linkNodes r1 $ Ref rn9 0 - linkNodes r2 $ Ref rn5 0 - linkNodes r3 $ Ref rn6 0 - linkNodes r4 $ Ref rn7 0 -{-# INLINABLE commute3' #-} - propagate1 :: HasRewriter sig m => Ref -> (() -> INetF ()) -> m () propagate1 r0 mk1 = do rn1 <- newNode $ const $ mk1 () @@ -697,11 +723,6 @@ propagate2 :: HasRewriter sig m => Ref -> Ref -> (() -> INetF ()) -> m () propagate2 r0 r1 mk1 = propagate1 r0 mk1 *> propagate1 r1 mk1 {-# INLINABLE propagate2 #-} -propagate3 - :: HasRewriter sig m => Ref -> Ref -> Ref -> (() -> INetF ()) -> m () -propagate3 r0 r1 r2 mk1 = propagate2 r0 r1 mk1 *> propagate1 r2 mk1 -{-# INLINABLE propagate3 #-} - copyIO1 :: HasRewriter sig m => Ref -> Ref -> (a -> () -> INetF ()) diff --git a/test/Golden.hs b/test/Golden.hs index a0742eb..aa8c8fa 100644 --- a/test/Golden.hs +++ b/test/Golden.hs @@ -34,7 +34,7 @@ import LLVM.PassManager (runPassManager, withPassManager) import LLVM.PassManager qualified as LLVM.Pass import Prettyprinter ( Doc, PageWidth(Unbounded) - , defaultLayoutOptions, layoutPageWidth, layoutPretty, line, pretty, (<+>) + , defaultLayoutOptions, layoutPageWidth, layoutPretty, line, nest, pretty, (<+>) ) import Prettyprinter.Render.Text (renderIO) import System.FilePath (replaceExtension, takeBaseName) @@ -69,6 +69,8 @@ compileFile file = runGolden $ \lh -> do liftIO $ hPutStrLn lh "Emitting" exts <- emitProgram prog graph <- get @INet + liftIO $ withFile (replaceExtension file ".inet") WriteMode + $ \h -> hPutDoc h $ pretty graph liftIO $ hPutStrLn lh "Interpreting" gen <- compileINet exts graph' <- get @INet @@ -79,8 +81,6 @@ compileFile file = runGolden $ \lh -> do , moduleDefinitions = llvmDefs } liftIO $ do - withFile (replaceExtension file ".inet") WriteMode - $ \h -> hPutDoc h $ pretty graph withFile (replaceExtension file ".opt.inet") WriteMode $ \h -> hPutDoc h $ pretty graph' withFile (replaceExtension file ".hl") WriteMode @@ -153,26 +153,16 @@ instance (MonadIO m, Has (State Count) sig m, Has (State INet) sig m r <- runTraceRewrite h . hdl $ cont <$ ctx lint size0 n0 n1 modify $ _Count %~ succ - case (n0, n1) of - (AppNode {}, _) -> pure r - (_, AppNode {}) -> pure r - (DupNode {}, _) -> pure r - (_, DupNode {}) -> pure r - (DeadNode {}, _) -> pure r - (_, DeadNode {}) -> pure r - (BoxNode {}, _) -> pure r - (_, BoxNode {}) -> pure r - _ -> do - count <- gets unCount - netSize <- gets (IM.size . unINet) - pairsSize <- gets (IS.size . unINetPairs) - liftIO $ hPrint h - $ pretty count - <+> pretty netSize - <+> pretty pairsSize - <+> prettyHead n0 - <+> prettyHead n1 - pure r + count <- gets unCount + netSize <- gets (IM.size . unINet) + pairsSize <- gets (IS.size . unINetPairs) + liftIO $ hPrint h + $ pretty count + <+> pretty netSize + <+> pretty pairsSize + <+> pretty size0 + <> nest 4 (line <> pretty n0 <> line <> pretty n1) + pure r R other -> alg (runTraceRewrite h . hdl) other ctx where lint :: Has (State INet) sig m => Int -> INetF Ref -> INetF Ref -> m () @@ -197,27 +187,6 @@ instance (MonadIO m, Has (State Count) sig m, Has (State INet) sig m <> line <> "Node 1: " <> pretty n0 <> line <> "Node 2: " <> pretty n1 <> line <> pretty net - - prettyHead :: INetF a -> Doc ann - prettyHead n0 = case n0 of - LamNode {} -> "Lam" - AppNode {} -> "App" - DupNode {} -> "Dup" - DeadNode {} -> "Dead" - BoxNode {} -> "Box" - RootNode {} -> "Root" - OperandNode {} -> "Operand" - OperandPNode {} -> "OperandP" - IONode {} -> "IO" - IOPNode {} -> "IOP" - IOContNode {} -> "IOCont" - Pure0Node {} -> "Pure0" - Bind0Node {} -> "Bind0" - Bind1Node {} -> "Bind1" - Branch0Node {} -> "Branch0" - Branch1Node {} -> "Branch1" - Branch2BNode {} -> "Branch2B" - Branch2PNode {} -> "Branch2P" {-# INLINE alg #-} newtype Count = Count { unCount :: Int } diff --git a/test/Golden/NestedBranch2.opt.ll b/test/Golden/NestedBranch2.opt.ll index f3f6341..70e08b3 100644 --- a/test/Golden/NestedBranch2.opt.ll +++ b/test/Golden/NestedBranch2.opt.ll @@ -3,7 +3,7 @@ source_filename = "test/Golden/NestedBranch2.elem" declare void @dothing(i4) local_unnamed_addr -define private fastcc void @"6391"(i4) unnamed_addr { +define private fastcc void @"7252"(i4) unnamed_addr { tail call void @dothing(i4 %0) tail call void @dothing(i4 %0) ret void @@ -14,7 +14,7 @@ define void @main(i4) local_unnamed_addr { br i1 %2, label %3, label %.sink.split .sink.split: ; preds = %1 - tail call fastcc void @"6391"(i4 %0) + tail call fastcc void @"7252"(i4 %0) br label %3 3: ; preds = %1, %.sink.split diff --git a/test/Golden/NestedBranch3.elem b/test/Golden/NestedBranch3.elem new file mode 100644 index 0000000..0368fa8 --- /dev/null +++ b/test/Golden/NestedBranch3.elem @@ -0,0 +1,25 @@ +foreign export "main" main : IO (∀ 0 → 0 → 0) + +foreign import c_dothing "dothing" + : IO (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +main = bindIO + @(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) c_dothing + @(∀ 0 → 0 → 0) (abort_if_null (λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) bindIO + @(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) c_dothing + @(∀ 0 → 0 → 0) (abort_if_null (λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) pureIO @(∀ 0 → 0 → 0) t)))) + +abort_if_null = λ((∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) → IO (∀ 0 → 0 → 0)) + λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + 0 @(∀ 0 → 0 → 0) (λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) + or 0 1 + ) @(IO (∀ 0 → 0 → 0)) (1 0) (pureIO @(∀ 0 → 0 → 0) f) + +or = λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) 1 @(∀ 0 → 0 → 0) t 0 + +f = Λ λ0 λ0 0 +t = Λ λ0 λ0 1 + diff --git a/test/Golden/NestedBranch3.opt.ll b/test/Golden/NestedBranch3.opt.ll new file mode 100644 index 0000000..f94df3c --- /dev/null +++ b/test/Golden/NestedBranch3.opt.ll @@ -0,0 +1,22 @@ +; ModuleID = '' +source_filename = "test/Golden/NestedBranch3.elem" + +declare i2 @dothing() local_unnamed_addr + +define private fastcc void @"2938"() unnamed_addr { + %1 = tail call i2 @dothing() + ret void +} + +define i1 @main() local_unnamed_addr { + %1 = tail call i2 @dothing() + %2 = icmp eq i2 %1, 0 + br i1 %2, label %3, label %.sink.split + +.sink.split: ; preds = %0 + tail call fastcc void @"2938"() + br label %3 + +3: ; preds = %0, %.sink.split + ret i1 false +} diff --git a/test/Golden/ShareIO.opt.ll b/test/Golden/ShareIO.opt.ll index ced7054..e90fe07 100644 --- a/test/Golden/ShareIO.opt.ll +++ b/test/Golden/ShareIO.opt.ll @@ -5,7 +5,7 @@ declare void @putbit(i1) local_unnamed_addr declare i1 @getbit() local_unnamed_addr -define private fastcc { i1, i1 } @"2485"() unnamed_addr { +define private fastcc { i1, i1 } @"2564"() unnamed_addr { %1 = tail call i1 @getbit() %2 = tail call i1 @getbit() %3 = insertvalue { i1, i1 } zeroinitializer, i1 %2, 1 @@ -14,7 +14,7 @@ define private fastcc { i1, i1 } @"2485"() unnamed_addr { } define void @main1() local_unnamed_addr { - %1 = tail call fastcc { i1, i1 } @"2485"() + %1 = tail call fastcc { i1, i1 } @"2564"() %2 = extractvalue { i1, i1 } %1, 1 %3 = extractvalue { i1, i1 } %1, 0 %4 = xor i1 %3, %2 @@ -23,7 +23,7 @@ define void @main1() local_unnamed_addr { } define void @main2() local_unnamed_addr { - %1 = tail call fastcc { i1, i1 } @"2485"() + %1 = tail call fastcc { i1, i1 } @"2564"() %2 = extractvalue { i1, i1 } %1, 1 %3 = extractvalue { i1, i1 } %1, 0 %4 = xor i1 %3, %2 diff --git a/test/Main.hs b/test/Main.hs index b690d11..a552516 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -27,5 +27,6 @@ tests = do ] where timeout :: Timeout - timeout = mkTimeout 5000000 -- 5s + -- timeout = mkTimeout 5000000 -- 5s + timeout = mkTimeout $ 7 * 86400 * 1000000 -- 7d From 62560606d173918405bda46e0f8e7955a09f744e Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Thu, 28 Apr 2022 07:00:15 +0100 Subject: [PATCH 04/17] Remove unused file I can't remember where it came from. Probably an old test case that has since been renamed or removed? --- test/Golden/ParserQuirks.opt.ll | 0 1 file changed, 0 insertions(+), 0 deletions(-) delete mode 100644 test/Golden/ParserQuirks.opt.ll diff --git a/test/Golden/ParserQuirks.opt.ll b/test/Golden/ParserQuirks.opt.ll deleted file mode 100644 index e69de29..0000000 From 5e314140102add1bde3279ce24d2f5ee06f1c748 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Fri, 29 Apr 2022 20:39:24 +0100 Subject: [PATCH 05/17] Add missing Branch3P/Dead interaction --- src/Language/Elemental/InteractionNet.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index e4e1cac..270706d 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -591,8 +591,9 @@ reduceNode n0@DeadNode {} n1@Branch1Node {} = reduceNode n1 n0 reduceNode (Branch2BNode _ _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@Branch2BNode {} = reduceNode n1 n0 reduceNode (Branch2PNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode -reduceNode (Branch3PNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@Branch2PNode {} = reduceNode n1 n0 +reduceNode (Branch3PNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode n0@DeadNode {} n1@Branch3PNode {} = reduceNode n1 n0 -- FFI Book-keeping reduceNode (RootNode name args _) (BoxNode _ _ r0) = propagate1 r0 $ RootNode name args From 3073a06ca3ab4fd3707faed4ed7367fb7d9b85b3 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Mon, 2 May 2022 15:34:58 +0100 Subject: [PATCH 06/17] Switch to a faster book-keeping strategy Unlike Lambdascope's strategy, this new strategy I've come up with does not require propagating book-keeping metadata through the interaction net. Consequently, it performs significantly better. Also unlike Lambdascope's strategy, it does not yet have a proof of correctness. :( --- src/Language/Elemental/Emit.hs | 15 +- src/Language/Elemental/InteractionNet.hs | 241 +++++++---------------- test/Golden.hs | 3 +- test/Golden/CataStaticDouble.elem | 24 +++ test/Golden/NestedBranch2.opt.ll | 4 +- test/Golden/NestedBranch3.opt.ll | 4 +- test/Golden/ShareIO.opt.ll | 6 +- test/Golden/SimpleArgs.opt.ll | 8 +- 8 files changed, 114 insertions(+), 191 deletions(-) diff --git a/src/Language/Elemental/Emit.hs b/src/Language/Elemental/Emit.hs index 2527cb9..9a139c0 100644 --- a/src/Language/Elemental/Emit.hs +++ b/src/Language/Elemental/Emit.hs @@ -144,7 +144,7 @@ emitExpr :: forall tscope scope tx sig m. HasRewriter sig m => SList (Const (Ref -> m ())) scope -> Ref -> Expr tscope scope tx -> m () emitExpr scope rr = \case - Var vidx -> mkBox vidx >>= getConst (scope !!^ vidx) + Var vidx -> getConst (scope !!^ vidx) rr App ef ex -> do rn1 <- newNode $ const $ AppNode () () () emitExpr scope (Ref rn1 0) ef @@ -198,7 +198,7 @@ emitExpr scope rr = \case let opp = Backend.Partial (SSucc $ SSucc SZero) $ Backend.InsertBit size size = fromIntegral $ toNatural ssize mkLambda rr $ OperandPNode opp - TestBit -> mkLambda rr $ Branch0Node 0 + TestBit -> mkLambda rr $ Branch0Node $ Level [] where coerceScope :: SList (Const a) as -> SList (Const a) (IncrementAll 'Zero as) coerceScope SNil = SNil @@ -208,14 +208,6 @@ emitExpr scope rr = \case withVarargs SZero f = f [] withVarargs (SSucc n) f = \x -> withVarargs n $ f . (x :) - mkBox :: SNat n -> m Ref - mkBox SZero = pure rr - mkBox (SSucc n) = do - r1 <- mkBox n - rn2 <- newNode $ const $ BoxNode 0 () () - linkNodes r1 $ Ref rn2 1 - pure $ Ref rn2 0 - mkIsolateBit :: Int -> Int -> Backend.Operand -> Backend.Operand mkIsolateBit size bidx (Backend.InsertBit _ oph opt) | bidx == 0 = oph @@ -242,7 +234,8 @@ emitExpr scope rr = \case case mr3 of Nothing -> put (r2, Just r1) Just r3 -> do - rn4 <- newNode $ const $ DupNode 0 mempty () () () + rn4 <- newNode $ \rn4 + -> DupNode Fanout (Level [rn4]) mempty () () () linkNodes r2 $ Ref rn4 0 linkNodes r3 $ Ref rn4 1 put (Ref rn4 2, Just r1) diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 270706d..6c55b8f 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -43,6 +43,7 @@ module Language.Elemental.InteractionNet , INetF(..) , Ref(..) , Level(..) + , DupKind(..) , Preaction(..) , Renames , HasRewriter @@ -130,11 +131,9 @@ data INetF a -- | (a -> b, a, b) | LamNode a a a -- | (a, a, a) - | DupNode Level Renames a a a + | DupNode DupKind Level Renames a a a -- | Void (i.e. any type) | DeadNode a - -- | (a, a) and the non-principal node is in a new box. - | BoxNode Level a a -- FFI -- | IO i{n} | RootNode B.Name [B.Named B.Type] a @@ -169,11 +168,10 @@ data INetF a instance Pretty a => Pretty (INetF a) where pretty (AppNode r0 r1 r2) = "App" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (LamNode r0 r1 r2) = "Lam" <+> pretty r0 <+> pretty r1 <+> pretty r2 - pretty (DupNode lvl _ r0 r1 r2) - = "Dup" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (DupNode dk lvl _ r0 r1 r2) + = "Dup" <+> pretty dk <+> pretty lvl + <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (DeadNode r0) = "Dead" <+> pretty r0 - pretty (BoxNode lvl r0 r1) - = "Box" <+> pretty lvl <+> pretty r0 <+> pretty r1 pretty (RootNode name args r0) = "Root" <+> pretty r0 <+> pretty name <+> tupled (pretty <$> args) pretty (OperandNode op r0) = "Operand" <+> pretty r0 <+> pretty op @@ -213,8 +211,15 @@ instance Ixed (INetF a) where type instance Index (INetF a) = Int type instance IxValue (INetF a) = a -newtype Level = Level { unLevel :: Int } - deriving newtype (Enum, Eq, Ord, Num, Pretty) +newtype Level = Level { unLevel :: [Int] } + deriving newtype (Eq, Ord, Pretty) + +data DupKind = Fanin | Fanout + deriving stock (Eq, Ord) + +instance Pretty DupKind where + pretty Fanin = "Fanin" + pretty Fanout = "Fanout" -- | Instructions that should run before a continuation. data Preaction @@ -311,53 +316,34 @@ reduce = try *> lintFinal reduceNode :: (HasRewriter sig m, Has (Writer (DList (B.Named B.Function))) sig m) => INetF Ref -> INetF Ref -> m () --- reduceNode (AppNode _ r0 r1) (AppNode _ r2 r3) --- = linkNodes r0 r2 *> linkNodes r1 r3 -reduceNode (AppNode _ r0 r1) (LamNode _ r2 r3) = do - rn4 <- newNode $ const $ BoxNode 0 () () - rn5 <- newNode $ const $ BoxNode 0 () () - linkNodes r0 $ Ref rn4 0 - linkNodes r1 $ Ref rn5 0 - linkNodes r2 $ Ref rn4 1 - linkNodes r3 $ Ref rn5 1 +reduceNode (AppNode _ r0 r1) (LamNode _ r2 r3) + = linkNodes r0 r2 *> linkNodes r1 r3 reduceNode n0@LamNode {} n1@AppNode {} = reduceNode n1 n0 -reduceNode (AppNode _ r0 r1) (DupNode lvl re _ r2 r3) - = commute2 AppNode (DupNode lvl re) r0 r1 r2 r3 +reduceNode (AppNode _ r0 r1) (DupNode Fanin lvl re _ r2 r3) = commute2' + AppNode AppNode (DupNode Fanout lvl re) (DupNode Fanin lvl re) r0 r1 r2 r3 reduceNode n0@DupNode {} n1@AppNode {} = reduceNode n1 n0 -reduceNode (LamNode _ r0 r1) (DupNode lvl re _ r2 r3) - = commute2 LamNode (DupNode (succ lvl) re) r0 r1 r2 r3 +reduceNode (LamNode _ r0 r1) (DupNode Fanout lvl re _ r2 r3) = commute2' + LamNode LamNode (DupNode Fanin lvl re) (DupNode Fanout lvl re) r0 r1 r2 r3 reduceNode n0@DupNode {} n1@LamNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl1 re1 _ r0 r1) (DupNode lvl2 re2 _ r2 r3) +reduceNode (DupNode Fanout lvl1 re1 (Ref idx1 _) r0 r1) + (DupNode Fanin lvl2 re2 (Ref idx2 _) r2 r3) | lvl1 == lvl2 = linkNodes r0 r2 *> linkNodes r1 r3 - | lvl1 == 10 && lvl2 == 11 || lvl1 == 11 && lvl2 == 10 = linkNodes r0 r2 *> linkNodes r1 r3 - | otherwise = commute2 (DupNode lvl1 re1) (DupNode lvl2 re2) r0 r1 r2 r3 + | otherwise = commute2' + (DupNode Fanout lvl11 re1) (DupNode Fanout lvl12 re1) + (DupNode Fanin lvl2 re2) (DupNode Fanin lvl2 re2) + r0 r1 r2 r3 + where + lvl11 = Level $ idx1 : unLevel lvl1 + lvl12 = Level $ idx2 : unLevel lvl1 +reduceNode n0@(DupNode Fanin _ _ _ _ _) n1@(DupNode Fanout _ _ _ _ _) + = reduceNode n1 n0 reduceNode (AppNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@AppNode {} = reduceNode n1 n0 reduceNode (LamNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@LamNode {} = reduceNode n1 n0 -reduceNode (DupNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode (DupNode _ _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DeadNode _) (DeadNode _) = pure () --- Book-keeping -reduceNode (AppNode _ r0 r1) (BoxNode lvl _ r2) - = commute1 AppNode (BoxNode lvl) r0 r1 r2 -reduceNode n0@BoxNode {} n1@AppNode {} = reduceNode n1 n0 -reduceNode (LamNode _ r0 r1) (BoxNode lvl _ r2) - = commute1 LamNode (BoxNode $ succ lvl) r0 r1 r2 -reduceNode n0@BoxNode {} n1@LamNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (BoxNode lvl1 _ r2) = commute1 - (DupNode (if lvl0 < lvl1 then lvl0 else succ lvl0) re) - (BoxNode lvl1) - r0 r1 r2 -reduceNode n0@BoxNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (BoxNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode -reduceNode n0@DeadNode {} n1@BoxNode {} = reduceNode n1 n0 -reduceNode (BoxNode lvl0 _ r0) (BoxNode lvl1 _ r1) - | lvl0 == lvl1 = linkNodes r0 r1 - | otherwise = commute0 - (BoxNode $ if lvl0 < lvl1 then lvl0 else succ lvl0) - (BoxNode $ if lvl1 < lvl0 then lvl1 else succ lvl1) - r0 r1 -- FFI reduceNode (RootNode name args _) (IONode b _) = tell $ pure @DList $ name B.:= B.Function args b @@ -437,17 +423,6 @@ reduceNode n0@IOContNode {} n1@Bind1Node {} = reduceNode n1 n0 reduceNode (Branch0Node lvl _ r0) (OperandNode op _) = mkLambda r0 $ Branch1Node lvl op reduceNode n0@OperandNode {} n1@Branch0Node {} = reduceNode n1 n0 -reduceNode (Branch1Node lvl op _ r0) (AppNode _ r1 r2) = do - rn3 <- newNode $ const $ Branch2PNode lvl op () () () - rn4 <- newNode $ const $ LamNode () () () - rn5 <- newNode $ const $ AppNode () () () - linkNodes (Ref rn3 0) (Ref rn4 1) - linkNodes (Ref rn3 1) (Ref rn5 0) - linkNodes (Ref rn3 2) (Ref rn4 2) - linkNodes r0 $ Ref rn4 0 - linkNodes r1 $ Ref rn5 1 - linkNodes r2 $ Ref rn5 2 -reduceNode n0@AppNode {} n1@Branch1Node {} = reduceNode n1 n0 reduceNode (Branch1Node lvl op _ r0) (LamNode _ r1 r2) = do rn3 <- newNode $ const $ Branch2PNode lvl op () () () rn4 <- newNode $ const $ LamNode () () () @@ -513,7 +488,7 @@ reduceNode n0@Branch3PNode {} n1@Branch2PNode {} = reduceNode n1 n0 reduceNode (Branch3PNode lvl opc _ r0 r1) (AppNode _ r2 r3) = do rn4 <- newNode $ const $ AppNode () () () rn5 <- newNode $ const $ AppNode () () () - rn6 <- newNode $ const $ DupNode 0 mempty () () () + rn6 <- newNode $ \rn6 -> DupNode Fanout (Level [rn6]) mempty () () () rn7 <- newNode $ const $ Branch1Node lvl opc () () rn8 <- newNode $ const $ AppNode () () () linkNodes (Ref rn4 1) (Ref rn6 1) @@ -527,44 +502,44 @@ reduceNode (Branch3PNode lvl opc _ r0 r1) (AppNode _ r2 r3) = do linkNodes r3 $ Ref rn8 2 reduceNode n0@AppNode {} n1@Branch3PNode {} = reduceNode n1 n0 -- FFI Duplication -reduceNode (DupNode _ re _ r0 r1) (OperandNode op _) +reduceNode (DupNode Fanout _ re _ r0 r1) (OperandNode op _) = copyIO1 r0 r1 OperandNode B.renameOp re op reduceNode n0@OperandNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (OperandPNode opp _ r2) - = copyIO2 lvl r0 r1 r2 OperandPNode (fmap . B.renameOp) re opp +reduceNode (DupNode Fanin lvl re _ r0 r1) (OperandPNode opp _ r2) + = copyIO2 Fanin lvl r0 r1 r2 OperandPNode (fmap . B.renameOp) re opp reduceNode n0@OperandPNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (IOPNode iop _ r2) - = copyIO2 lvl r0 r1 r2 IOPNode (fmap . B.renameInstr) re iop +reduceNode (DupNode Fanin lvl re _ r0 r1) (IOPNode iop _ r2) + = copyIO2 Fanin lvl r0 r1 r2 IOPNode (fmap . B.renameInstr) re iop reduceNode n0@IOPNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (IOContNode nbs _ r2) +reduceNode (DupNode Fanout lvl re _ r0 r1) (IOContNode nbs _ r2) = shareIOCont lvl re nbs r0 r1 r2 reduceNode n0@IOContNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (Pure0Node _ r2) - = commute1 (DupNode lvl re) Pure0Node r0 r1 r2 +reduceNode (DupNode Fanin lvl re _ r0 r1) (Pure0Node _ r2) + = commute1 (DupNode Fanin lvl re) Pure0Node r0 r1 r2 reduceNode n0@Pure0Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (Bind0Node _ r2) - = commute1 (DupNode lvl re) Bind0Node r0 r1 r2 +reduceNode (DupNode Fanin lvl re _ r0 r1) (Bind0Node _ r2) + = commute1 (DupNode Fanin lvl re) Bind0Node r0 r1 r2 reduceNode n0@Bind0Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (Bind1Node nbs _ r2) +reduceNode (DupNode Fanin lvl re _ r0 r1) (Bind1Node nbs _ r2) = shareBind1 lvl re nbs r0 r1 r2 reduceNode n0@Bind1Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch0Node lvl1 _ r2) - = commute1 (DupNode lvl0 re) (Branch0Node lvl1) r0 r1 r2 +reduceNode (DupNode Fanin lvl0 re _ r0 r1) (Branch0Node lvl1 _ r2) + = commute1 (DupNode Fanin lvl0 re) (Branch0Node lvl1) r0 r1 r2 reduceNode n0@Branch0Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch1Node lvl1 op _ r2) - = copyIO2 lvl0 r0 r1 r2 (Branch1Node lvl1) B.renameOp re op +reduceNode (DupNode Fanin lvl0 re _ r0 r1) (Branch1Node lvl1 op _ r2) + = copyIO2 Fanin lvl0 r0 r1 r2 (Branch1Node lvl1) B.renameOp re op reduceNode n0@Branch1Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch2BNode lvl1 opc nbt _ r2 r3) +reduceNode (DupNode Fanin lvl0 re _ r0 r1) (Branch2BNode lvl1 opc nbt _ r2 r3) = shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 reduceNode n0@Branch2BNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch2PNode lvl1 op _ r2 r3) - = commute2' (DupNode lvl0 re) (DupNode lvl0 re) +reduceNode (DupNode Fanin lvl0 re _ r0 r1) (Branch2PNode lvl1 op _ r2 r3) + = commute2' (DupNode Fanout lvl0 re) (DupNode Fanin lvl0 re) (Branch2PNode lvl1 $ B.renameOp (M.map fst re) op) (Branch2PNode lvl1 $ B.renameOp (M.map snd re) op) r0 r1 r2 r3 reduceNode n0@Branch2PNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch3PNode lvl1 op _ r2 r3) - = commute2' (DupNode lvl0 re) (DupNode lvl0 re) +reduceNode (DupNode Fanout lvl0 re _ r0 r1) (Branch3PNode lvl1 op _ r2 r3) + = commute2' (DupNode Fanout lvl0 re) (DupNode Fanout lvl0 re) (Branch3PNode lvl1 $ B.renameOp (M.map fst re) op) (Branch3PNode lvl1 $ B.renameOp (M.map snd re) op) r0 r1 r2 r3 @@ -595,72 +570,10 @@ reduceNode n0@DeadNode {} n1@Branch2PNode {} = reduceNode n1 n0 reduceNode (Branch3PNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@Branch3PNode {} = reduceNode n1 n0 -- FFI Book-keeping -reduceNode (RootNode name args _) (BoxNode _ _ r0) - = propagate1 r0 $ RootNode name args -reduceNode n0@BoxNode {} n1@RootNode {} = reduceNode n1 n0 -reduceNode (OperandNode op _) (BoxNode _ _ r0) - = propagate1 r0 $ OperandNode op -reduceNode n0@BoxNode {} n1@OperandNode {} = reduceNode n1 n0 -reduceNode (OperandPNode opp _ r0) (BoxNode lvl _ r1) - = commute0 (OperandPNode opp) (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@OperandPNode {} = reduceNode n1 n0 -reduceNode (IONode b _) (BoxNode _ _ r0) - = propagate1 r0 $ IONode b -reduceNode n0@BoxNode {} n1@IONode {} = reduceNode n1 n0 -reduceNode (IOPNode iop _ r0) (BoxNode lvl _ r1) - = commute0 (IOPNode iop) (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@IOPNode {} = reduceNode n1 n0 -reduceNode (IOContNode nbs _ r0) (BoxNode lvl _ r1) - = commute0 (IOContNode nbs) (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@IOContNode {} = reduceNode n1 n0 -reduceNode (Pure0Node _ r0) (BoxNode lvl _ r1) - = commute0 Pure0Node (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@Pure0Node {} = reduceNode n1 n0 -reduceNode (Bind0Node _ r0) (BoxNode lvl _ r1) - = commute0 Bind0Node (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@Bind0Node {} = reduceNode n1 n0 -reduceNode (Bind1Node nbs _ r0) (BoxNode lvl _ r1) - = commute0 (Bind1Node nbs) (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@Bind1Node {} = reduceNode n1 n0 -reduceNode (Branch0Node lvl0 _ r0) (BoxNode lvl1 _ r1) = commute0 - (Branch0Node $ if lvl0 < lvl1 then lvl0 else succ lvl0) (BoxNode lvl1) r0 r1 -reduceNode n0@BoxNode {} n1@Branch0Node {} = reduceNode n1 n0 -reduceNode (Branch1Node lvl0 op _ r0) (BoxNode lvl1 _ r1) = commute0 - (Branch1Node (if lvl0 < lvl1 then lvl0 else succ lvl0) op) - (BoxNode lvl1) - r0 r1 -reduceNode n0@BoxNode {} n1@Branch1Node {} = reduceNode n1 n0 -reduceNode (Branch2BNode lvl0 opc nbt _ r0 r1) (BoxNode lvl1 _ r2) = commute1 - (Branch2BNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc nbt) - (BoxNode lvl1) - r0 r1 r2 -reduceNode n0@BoxNode {} n1@Branch2BNode {} = reduceNode n1 n0 -reduceNode (Branch2PNode lvl0 opc _ r0 r1) (BoxNode lvl1 _ r2) = commute1 - (Branch2PNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc) - (BoxNode lvl1) - r0 r1 r2 -reduceNode n0@BoxNode {} n1@Branch2PNode {} = reduceNode n1 n0 -reduceNode (Branch3PNode lvl0 opc _ r0 r1) (BoxNode lvl1 _ r2) = commute1 - (Branch3PNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc) - (BoxNode lvl1) - r0 r1 r2 -reduceNode n0@BoxNode {} n1@Branch3PNode {} = reduceNode n1 n0 reduceNode n0 n1 = error . show $ "unexpected node pairing" <> line <> pretty n0 <> line <> pretty n1 {-# INLINABLE reduceNode #-} -commute0 - :: HasRewriter sig m - => (() -> () -> INetF ()) -> (() -> () -> INetF ()) - -> Ref -> Ref -> m () -commute0 mk1 mk2 r0 r1 = do - rn3 <- newNode $ const $ mk2 () () - rn4 <- newNode $ const $ mk1 () () - linkNodes (Ref rn3 1) (Ref rn4 1) - linkNodes r0 $ Ref rn3 0 - linkNodes r1 $ Ref rn4 0 -{-# INLINABLE commute0 #-} - commute1 :: HasRewriter sig m => (() -> () -> () -> INetF ()) -> (() -> () -> INetF ()) @@ -684,14 +597,6 @@ commute1' mk1 mk2a mk2b r0 r1 r2 = do linkNodes r2 $ Ref rn5 0 {-# INLINABLE commute1' #-} -commute2 - :: HasRewriter sig m - => (() -> () -> () -> INetF ()) - -> (() -> () -> () -> INetF ()) - -> Ref -> Ref -> Ref -> Ref -> m () -commute2 mk1 mk2 = commute2' mk1 mk1 mk2 mk2 -{-# INLINABLE commute2 #-} - commute2' :: HasRewriter sig m => (() -> () -> () -> INetF ()) @@ -736,21 +641,22 @@ copyIO1 r0 r1 mk1 f re ffi = do copyIO2 :: HasRewriter sig m - => Level -> Ref -> Ref -> Ref -> (a -> () -> () -> INetF ()) + => DupKind -> Level -> Ref -> Ref -> Ref -> (a -> () -> () -> INetF ()) -> (M.Map B.Name B.Operand -> a -> a) -> Renames -> a -> m () -copyIO2 lvl r0 r1 r2 mk1 f re ffi = commute1' (DupNode lvl re) +copyIO2 dk lvl r0 r1 r2 mk1 f re ffi = commute1' (DupNode dk lvl re) (mk1 $ f (M.map fst re) ffi) (mk1 $ f (M.map snd re) ffi) r0 r1 r2 {-# INLINABLE copyIO2 #-} copyIO3 :: HasRewriter sig m - => Level -> Ref -> Ref -> Ref -> Ref -> (a -> () -> () -> () -> INetF ()) + => DupKind -> DupKind -> Level -> Ref -> Ref -> Ref -> Ref + -> (a -> () -> () -> () -> INetF ()) -> (M.Map B.Name B.Operand -> a -> a) -> Renames -> a -> m () -copyIO3 lvl r0 r1 r2 r3 mk1 f re ffi = commute2' - (DupNode lvl re) (DupNode lvl re) +copyIO3 dk1 dk2 lvl r0 r1 r2 r3 mk1 f re ffi = commute2' + (DupNode dk1 lvl re) (DupNode dk2 lvl re) (mk1 $ f (M.map fst re) ffi) (mk1 $ f (M.map snd re) ffi) r0 r1 r2 r3 @@ -759,16 +665,17 @@ copyIO3 lvl r0 r1 r2 r3 mk1 f re ffi = commute2' shareIOCont :: HasRewriter sig m => Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () -shareIOCont = sharePreaction (<>) (pure pure) (pure pure) IOContNode +shareIOCont = sharePreaction (<>) (pure pure) (pure pure) IOContNode Fanout {-# INLINABLE shareIOCont #-} shareBind1 :: HasRewriter sig m => Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () -shareBind1 lvl = sharePreaction (const id) (wrap fst) (wrap snd) Bind1Node lvl +shareBind1 lvl + = sharePreaction (const id) (wrap fst) (wrap snd) Bind1Node Fanin lvl where wrap sel re r0 = do - rn1 <- newNode $ const $ DupNode lvl re () () () + rn1 <- newNode $ const $ DupNode Fanout lvl re () () () rn2 <- newNode $ const $ DeadNode () linkNodes (Ref rn1 $ sel (2, 1)) (Ref rn2 0) linkNodes r0 $ Ref rn1 $ sel (1, 2) @@ -780,15 +687,15 @@ shareBranch2B => Level -> Level -> Renames -> B.Operand -> Preaction -> Ref -> Ref -> Ref -> Ref -> m () shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 = case sharePreaction' nbt of - Nothing -> copyIO3 lvl0 r0 r1 r2 r3 mk renamePreaction re nbt + Nothing -> copyIO3 Fanout Fanin lvl0 r0 r1 r2 r3 mk renamePreaction re nbt Just (name, sb) | null (B.bodyInstrs sb) -> do let mkPreaction rn = SimplePreaction (mkName rn) sb rn4 <- newNode $ \rn4 -> mk (mkPreaction rn4) () () () rn5 <- newNode $ \rn5 -> mk (mkPreaction rn5) () () () let re' = M.singleton name (mkRef t rn4, mkRef t rn5) t = B.instrType $ B.bodyTerm sb - rn6 <- newNode $ const $ DupNode lvl0 re () () () - rn7 <- newNode $ const $ DupNode lvl0 re () () () + rn6 <- newNode $ const $ DupNode Fanout lvl0 re () () () + rn7 <- newNode $ const $ DupNode Fanin lvl0 re () () () r8 <- w1 re' $ Ref rn4 0 r9 <- w2 re' $ Ref rn5 0 linkNodes (Ref rn4 1) (Ref rn6 1) @@ -822,8 +729,8 @@ shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 = case sharePreaction' nbt of rn6 <- newNode $ \rn6 -> mk (mkPreact fst rn6) () () () rn7 <- newNode $ \rn7 -> mk (mkPreact snd rn7) () () () let re' = M.fromList $ zipWith (dupNames gop ltt rn5 rn6) [0..] names - rn8 <- newNode $ const $ DupNode lvl0 re () () () - rn9 <- newNode $ const $ DupNode lvl0 re () () () + rn8 <- newNode $ const $ DupNode Fanout lvl0 re () () () + rn9 <- newNode $ const $ DupNode Fanin lvl0 re () () () r10 <- w1 re' (Ref rn6 0) r11 <- w2 re' (Ref rn7 0) linkNodes (Ref rn4 0) (Ref rn5 0) @@ -841,7 +748,7 @@ shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 = case sharePreaction' nbt of w2 = wrap snd wrap sel re' r4 = do - rn5 <- newNode $ const $ DupNode lvl0 re' () () () + rn5 <- newNode $ const $ DupNode Fanout lvl0 re' () () () rn6 <- newNode $ const $ DeadNode () linkNodes (Ref rn5 $ sel (2, 1)) (Ref rn6 0) linkNodes r4 $ Ref rn5 $ sel (1, 2) @@ -859,16 +766,16 @@ sharePreaction => (Renames -> Renames -> Renames) -> (Renames -> Ref -> m Ref) -> (Renames -> Ref -> m Ref) -> (Preaction -> () -> () -> INetF ()) - -> Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () -sharePreaction append w1 w2 mk lvl re nbs r0 r1 r2 = case sharePreaction' nbs of - Nothing -> copyIO2 lvl r0 r1 r2 mk renamePreaction re nbs + -> DupKind -> Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () +sharePreaction append w1 w2 mk dk lvl re nbs r0 r1 r2 = case sharePreaction' nbs of + Nothing -> copyIO2 dk lvl r0 r1 r2 mk renamePreaction re nbs Just (name, sb) | null (B.bodyInstrs sb) -> do let mkPreaction rn = SimplePreaction (mkName rn) sb rn3 <- newNode $ \rn3 -> mk (mkPreaction rn3) () () rn4 <- newNode $ \rn4 -> mk (mkPreaction rn4) () () let re' = M.singleton name (mkRef t rn3, mkRef t rn4) t = B.instrType $ B.bodyTerm sb - rn5 <- newNode $ const $ DupNode lvl (append re' re) () () () + rn5 <- newNode $ const $ DupNode dk lvl (append re' re) () () () r6 <- w1 re' $ Ref rn3 0 r7 <- w2 re' $ Ref rn4 0 linkNodes (Ref rn3 1) (Ref rn5 1) @@ -899,7 +806,7 @@ sharePreaction append w1 w2 mk lvl re nbs r0 r1 r2 = case sharePreaction' nbs of rn5 <- newNode $ \rn5 -> mk (mkPreact fst rn5) () () rn6 <- newNode $ \rn6 -> mk (mkPreact snd rn6) () () let re' = M.fromList $ zipWith (dupNames gop ltt rn5 rn6) [0..] names - rn7 <- newNode $ const $ DupNode lvl (append re' re) () () () + rn7 <- newNode $ const $ DupNode dk lvl (append re' re) () () () r8 <- w1 re' (Ref rn5 0) r9 <- w2 re' (Ref rn6 0) linkNodes (Ref rn3 0) (Ref rn4 0) diff --git a/test/Golden.hs b/test/Golden.hs index aa8c8fa..8b27523 100644 --- a/test/Golden.hs +++ b/test/Golden.hs @@ -12,7 +12,7 @@ module Golden where import Control.Algebra (Algebra(alg), Has, (:+:)(L, R), run) -import Control.Carrier.Reader (ReaderC(ReaderC), runReader) +import Control.Carrier.Reader (ReaderC(ReaderC)) import Control.Carrier.State.Church (State, evalState, get, gets, modify) import Control.Lens (Iso', iso, ix, (^?), (%~)) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -113,7 +113,6 @@ compileFile file = runGolden $ \lh -> do $ evalState @INetPairs mempty $ evalState @INetSize 0 $ evalState @Count 0 - $ runReader @Level 0 $ runTraceRewrite <*> m $ lh printDiags :: DiagnosisC Diagnostic Identity a -> a diff --git a/test/Golden/CataStaticDouble.elem b/test/Golden/CataStaticDouble.elem index f360087..01a4695 100644 --- a/test/Golden/CataStaticDouble.elem +++ b/test/Golden/CataStaticDouble.elem @@ -6,16 +6,40 @@ main = count @(IO (∀ 0 → 0)) (λ(∀ 0 → (IO (∀ 0 → 0) → 0) → 0) 0 @(IO (∀ 0 → 0)) (pureIO @(∀ 0 → 0) (Λ λ0 0)) (λ(IO (∀ 0 → 0)) bindIO @(∀ 0 → 0) 0 @(∀ 0 → 0) (λ(∀ 0 → 0) c_dothing)) + -- (λ(IO (∀ 0 → 0)) 0) ) count = double (double (succ zero)) +-- count = double (succ (succ2 zero)) +-- count = double (Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 +-- ((λ((∀ 0 → (2 → 0) → 0) → 1) 0 (Λ λ0 λ(2 → 0) 0 (2 (Λ λ0 λ(3 → 0) 1)))) 2))) +-- count = double (Λ λ((∀ 0 → (1 → 0) → 0) → 0) +-- (λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (2 (Λ λ0 λ(2 → 0) 1)))) 0) + +-- count = double count1 +-- count1 = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (2 (Λ λ0 λ(2 → 0) 0 (4 (Λ λ0 λ(3 → 0) 1))))) double = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (λ(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 1 succ) + -- 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 1 (λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 0)) zero = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 1) succ = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (3 @1 2)) +{- +succ2 = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (3 @1 2)) +-} + +{- + succ zero = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (2 (Λ λ0 λ(1 → 0) 1))) + succ (succ zero) = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (succ zero @1 2)) + + double = \a -> a (\b -> b a (\c -> c)) + -- count = double (\a -> a (\_ b -> b ((\c -> c (\_ d -> d (c (\e _ -> e)))) a))) + count = double (\a -> (\b -> b (\_ c -> c (b (\d _ -> d)))) a) + double has level 83 + count has level 92 +-} foreign primitive pureIO : ∀ 0 → IO 0 foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 diff --git a/test/Golden/NestedBranch2.opt.ll b/test/Golden/NestedBranch2.opt.ll index 70e08b3..23f59b1 100644 --- a/test/Golden/NestedBranch2.opt.ll +++ b/test/Golden/NestedBranch2.opt.ll @@ -3,7 +3,7 @@ source_filename = "test/Golden/NestedBranch2.elem" declare void @dothing(i4) local_unnamed_addr -define private fastcc void @"7252"(i4) unnamed_addr { +define private fastcc void @"570"(i4) unnamed_addr { tail call void @dothing(i4 %0) tail call void @dothing(i4 %0) ret void @@ -14,7 +14,7 @@ define void @main(i4) local_unnamed_addr { br i1 %2, label %3, label %.sink.split .sink.split: ; preds = %1 - tail call fastcc void @"7252"(i4 %0) + tail call fastcc void @"570"(i4 %0) br label %3 3: ; preds = %1, %.sink.split diff --git a/test/Golden/NestedBranch3.opt.ll b/test/Golden/NestedBranch3.opt.ll index f94df3c..1f08031 100644 --- a/test/Golden/NestedBranch3.opt.ll +++ b/test/Golden/NestedBranch3.opt.ll @@ -3,7 +3,7 @@ source_filename = "test/Golden/NestedBranch3.elem" declare i2 @dothing() local_unnamed_addr -define private fastcc void @"2938"() unnamed_addr { +define private fastcc void @"411"() unnamed_addr { %1 = tail call i2 @dothing() ret void } @@ -14,7 +14,7 @@ define i1 @main() local_unnamed_addr { br i1 %2, label %3, label %.sink.split .sink.split: ; preds = %0 - tail call fastcc void @"2938"() + tail call fastcc void @"411"() br label %3 3: ; preds = %0, %.sink.split diff --git a/test/Golden/ShareIO.opt.ll b/test/Golden/ShareIO.opt.ll index e90fe07..8cde567 100644 --- a/test/Golden/ShareIO.opt.ll +++ b/test/Golden/ShareIO.opt.ll @@ -5,7 +5,7 @@ declare void @putbit(i1) local_unnamed_addr declare i1 @getbit() local_unnamed_addr -define private fastcc { i1, i1 } @"2564"() unnamed_addr { +define private fastcc { i1, i1 } @"233"() unnamed_addr { %1 = tail call i1 @getbit() %2 = tail call i1 @getbit() %3 = insertvalue { i1, i1 } zeroinitializer, i1 %2, 1 @@ -14,7 +14,7 @@ define private fastcc { i1, i1 } @"2564"() unnamed_addr { } define void @main1() local_unnamed_addr { - %1 = tail call fastcc { i1, i1 } @"2564"() + %1 = tail call fastcc { i1, i1 } @"233"() %2 = extractvalue { i1, i1 } %1, 1 %3 = extractvalue { i1, i1 } %1, 0 %4 = xor i1 %3, %2 @@ -23,7 +23,7 @@ define void @main1() local_unnamed_addr { } define void @main2() local_unnamed_addr { - %1 = tail call fastcc { i1, i1 } @"2564"() + %1 = tail call fastcc { i1, i1 } @"233"() %2 = extractvalue { i1, i1 } %1, 1 %3 = extractvalue { i1, i1 } %1, 0 %4 = xor i1 %3, %2 diff --git a/test/Golden/SimpleArgs.opt.ll b/test/Golden/SimpleArgs.opt.ll index 00ecb3a..d884c87 100644 --- a/test/Golden/SimpleArgs.opt.ll +++ b/test/Golden/SimpleArgs.opt.ll @@ -2,13 +2,13 @@ source_filename = "test/Golden/SimpleArgs.elem" ; Function Attrs: norecurse nounwind readnone -define i1 @main(i1 returned) local_unnamed_addr #0 { - ret i1 %0 +define i1 @snd(i1, i1 returned) local_unnamed_addr #0 { + ret i1 %1 } ; Function Attrs: norecurse nounwind readnone -define i1 @snd(i1, i1 returned) local_unnamed_addr #0 { - ret i1 %1 +define i1 @main(i1 returned) local_unnamed_addr #0 { + ret i1 %0 } attributes #0 = { norecurse nounwind readnone } From 59c17979b8271d9ebce066cce64d70809792e61d Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Mon, 9 May 2022 17:20:05 +0100 Subject: [PATCH 07/17] Revert "Switch to a faster book-keeping strategy" This reverts commit 3073a06ca3ab4fd3707faed4ed7367fb7d9b85b3. The change doesn't always work and gets in the way of improving other aspects. --- src/Language/Elemental/Emit.hs | 15 +- src/Language/Elemental/InteractionNet.hs | 241 ++++++++++++++++------- test/Golden.hs | 3 +- test/Golden/CataStaticDouble.elem | 24 --- test/Golden/NestedBranch2.opt.ll | 4 +- test/Golden/NestedBranch3.opt.ll | 4 +- test/Golden/ShareIO.opt.ll | 6 +- test/Golden/SimpleArgs.opt.ll | 8 +- 8 files changed, 191 insertions(+), 114 deletions(-) diff --git a/src/Language/Elemental/Emit.hs b/src/Language/Elemental/Emit.hs index 9a139c0..2527cb9 100644 --- a/src/Language/Elemental/Emit.hs +++ b/src/Language/Elemental/Emit.hs @@ -144,7 +144,7 @@ emitExpr :: forall tscope scope tx sig m. HasRewriter sig m => SList (Const (Ref -> m ())) scope -> Ref -> Expr tscope scope tx -> m () emitExpr scope rr = \case - Var vidx -> getConst (scope !!^ vidx) rr + Var vidx -> mkBox vidx >>= getConst (scope !!^ vidx) App ef ex -> do rn1 <- newNode $ const $ AppNode () () () emitExpr scope (Ref rn1 0) ef @@ -198,7 +198,7 @@ emitExpr scope rr = \case let opp = Backend.Partial (SSucc $ SSucc SZero) $ Backend.InsertBit size size = fromIntegral $ toNatural ssize mkLambda rr $ OperandPNode opp - TestBit -> mkLambda rr $ Branch0Node $ Level [] + TestBit -> mkLambda rr $ Branch0Node 0 where coerceScope :: SList (Const a) as -> SList (Const a) (IncrementAll 'Zero as) coerceScope SNil = SNil @@ -208,6 +208,14 @@ emitExpr scope rr = \case withVarargs SZero f = f [] withVarargs (SSucc n) f = \x -> withVarargs n $ f . (x :) + mkBox :: SNat n -> m Ref + mkBox SZero = pure rr + mkBox (SSucc n) = do + r1 <- mkBox n + rn2 <- newNode $ const $ BoxNode 0 () () + linkNodes r1 $ Ref rn2 1 + pure $ Ref rn2 0 + mkIsolateBit :: Int -> Int -> Backend.Operand -> Backend.Operand mkIsolateBit size bidx (Backend.InsertBit _ oph opt) | bidx == 0 = oph @@ -234,8 +242,7 @@ emitExpr scope rr = \case case mr3 of Nothing -> put (r2, Just r1) Just r3 -> do - rn4 <- newNode $ \rn4 - -> DupNode Fanout (Level [rn4]) mempty () () () + rn4 <- newNode $ const $ DupNode 0 mempty () () () linkNodes r2 $ Ref rn4 0 linkNodes r3 $ Ref rn4 1 put (Ref rn4 2, Just r1) diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 6c55b8f..270706d 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -43,7 +43,6 @@ module Language.Elemental.InteractionNet , INetF(..) , Ref(..) , Level(..) - , DupKind(..) , Preaction(..) , Renames , HasRewriter @@ -131,9 +130,11 @@ data INetF a -- | (a -> b, a, b) | LamNode a a a -- | (a, a, a) - | DupNode DupKind Level Renames a a a + | DupNode Level Renames a a a -- | Void (i.e. any type) | DeadNode a + -- | (a, a) and the non-principal node is in a new box. + | BoxNode Level a a -- FFI -- | IO i{n} | RootNode B.Name [B.Named B.Type] a @@ -168,10 +169,11 @@ data INetF a instance Pretty a => Pretty (INetF a) where pretty (AppNode r0 r1 r2) = "App" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (LamNode r0 r1 r2) = "Lam" <+> pretty r0 <+> pretty r1 <+> pretty r2 - pretty (DupNode dk lvl _ r0 r1 r2) - = "Dup" <+> pretty dk <+> pretty lvl - <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (DupNode lvl _ r0 r1 r2) + = "Dup" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (DeadNode r0) = "Dead" <+> pretty r0 + pretty (BoxNode lvl r0 r1) + = "Box" <+> pretty lvl <+> pretty r0 <+> pretty r1 pretty (RootNode name args r0) = "Root" <+> pretty r0 <+> pretty name <+> tupled (pretty <$> args) pretty (OperandNode op r0) = "Operand" <+> pretty r0 <+> pretty op @@ -211,15 +213,8 @@ instance Ixed (INetF a) where type instance Index (INetF a) = Int type instance IxValue (INetF a) = a -newtype Level = Level { unLevel :: [Int] } - deriving newtype (Eq, Ord, Pretty) - -data DupKind = Fanin | Fanout - deriving stock (Eq, Ord) - -instance Pretty DupKind where - pretty Fanin = "Fanin" - pretty Fanout = "Fanout" +newtype Level = Level { unLevel :: Int } + deriving newtype (Enum, Eq, Ord, Num, Pretty) -- | Instructions that should run before a continuation. data Preaction @@ -316,34 +311,53 @@ reduce = try *> lintFinal reduceNode :: (HasRewriter sig m, Has (Writer (DList (B.Named B.Function))) sig m) => INetF Ref -> INetF Ref -> m () -reduceNode (AppNode _ r0 r1) (LamNode _ r2 r3) - = linkNodes r0 r2 *> linkNodes r1 r3 +-- reduceNode (AppNode _ r0 r1) (AppNode _ r2 r3) +-- = linkNodes r0 r2 *> linkNodes r1 r3 +reduceNode (AppNode _ r0 r1) (LamNode _ r2 r3) = do + rn4 <- newNode $ const $ BoxNode 0 () () + rn5 <- newNode $ const $ BoxNode 0 () () + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn5 0 + linkNodes r2 $ Ref rn4 1 + linkNodes r3 $ Ref rn5 1 reduceNode n0@LamNode {} n1@AppNode {} = reduceNode n1 n0 -reduceNode (AppNode _ r0 r1) (DupNode Fanin lvl re _ r2 r3) = commute2' - AppNode AppNode (DupNode Fanout lvl re) (DupNode Fanin lvl re) r0 r1 r2 r3 +reduceNode (AppNode _ r0 r1) (DupNode lvl re _ r2 r3) + = commute2 AppNode (DupNode lvl re) r0 r1 r2 r3 reduceNode n0@DupNode {} n1@AppNode {} = reduceNode n1 n0 -reduceNode (LamNode _ r0 r1) (DupNode Fanout lvl re _ r2 r3) = commute2' - LamNode LamNode (DupNode Fanin lvl re) (DupNode Fanout lvl re) r0 r1 r2 r3 +reduceNode (LamNode _ r0 r1) (DupNode lvl re _ r2 r3) + = commute2 LamNode (DupNode (succ lvl) re) r0 r1 r2 r3 reduceNode n0@DupNode {} n1@LamNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanout lvl1 re1 (Ref idx1 _) r0 r1) - (DupNode Fanin lvl2 re2 (Ref idx2 _) r2 r3) +reduceNode (DupNode lvl1 re1 _ r0 r1) (DupNode lvl2 re2 _ r2 r3) | lvl1 == lvl2 = linkNodes r0 r2 *> linkNodes r1 r3 - | otherwise = commute2' - (DupNode Fanout lvl11 re1) (DupNode Fanout lvl12 re1) - (DupNode Fanin lvl2 re2) (DupNode Fanin lvl2 re2) - r0 r1 r2 r3 - where - lvl11 = Level $ idx1 : unLevel lvl1 - lvl12 = Level $ idx2 : unLevel lvl1 -reduceNode n0@(DupNode Fanin _ _ _ _ _) n1@(DupNode Fanout _ _ _ _ _) - = reduceNode n1 n0 + | lvl1 == 10 && lvl2 == 11 || lvl1 == 11 && lvl2 == 10 = linkNodes r0 r2 *> linkNodes r1 r3 + | otherwise = commute2 (DupNode lvl1 re1) (DupNode lvl2 re2) r0 r1 r2 r3 reduceNode (AppNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@AppNode {} = reduceNode n1 n0 reduceNode (LamNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@LamNode {} = reduceNode n1 n0 -reduceNode (DupNode _ _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode (DupNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DeadNode _) (DeadNode _) = pure () +-- Book-keeping +reduceNode (AppNode _ r0 r1) (BoxNode lvl _ r2) + = commute1 AppNode (BoxNode lvl) r0 r1 r2 +reduceNode n0@BoxNode {} n1@AppNode {} = reduceNode n1 n0 +reduceNode (LamNode _ r0 r1) (BoxNode lvl _ r2) + = commute1 LamNode (BoxNode $ succ lvl) r0 r1 r2 +reduceNode n0@BoxNode {} n1@LamNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 re _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (DupNode (if lvl0 < lvl1 then lvl0 else succ lvl0) re) + (BoxNode lvl1) + r0 r1 r2 +reduceNode n0@BoxNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (BoxNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@BoxNode {} = reduceNode n1 n0 +reduceNode (BoxNode lvl0 _ r0) (BoxNode lvl1 _ r1) + | lvl0 == lvl1 = linkNodes r0 r1 + | otherwise = commute0 + (BoxNode $ if lvl0 < lvl1 then lvl0 else succ lvl0) + (BoxNode $ if lvl1 < lvl0 then lvl1 else succ lvl1) + r0 r1 -- FFI reduceNode (RootNode name args _) (IONode b _) = tell $ pure @DList $ name B.:= B.Function args b @@ -423,6 +437,17 @@ reduceNode n0@IOContNode {} n1@Bind1Node {} = reduceNode n1 n0 reduceNode (Branch0Node lvl _ r0) (OperandNode op _) = mkLambda r0 $ Branch1Node lvl op reduceNode n0@OperandNode {} n1@Branch0Node {} = reduceNode n1 n0 +reduceNode (Branch1Node lvl op _ r0) (AppNode _ r1 r2) = do + rn3 <- newNode $ const $ Branch2PNode lvl op () () () + rn4 <- newNode $ const $ LamNode () () () + rn5 <- newNode $ const $ AppNode () () () + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes (Ref rn3 1) (Ref rn5 0) + linkNodes (Ref rn3 2) (Ref rn4 2) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn5 1 + linkNodes r2 $ Ref rn5 2 +reduceNode n0@AppNode {} n1@Branch1Node {} = reduceNode n1 n0 reduceNode (Branch1Node lvl op _ r0) (LamNode _ r1 r2) = do rn3 <- newNode $ const $ Branch2PNode lvl op () () () rn4 <- newNode $ const $ LamNode () () () @@ -488,7 +513,7 @@ reduceNode n0@Branch3PNode {} n1@Branch2PNode {} = reduceNode n1 n0 reduceNode (Branch3PNode lvl opc _ r0 r1) (AppNode _ r2 r3) = do rn4 <- newNode $ const $ AppNode () () () rn5 <- newNode $ const $ AppNode () () () - rn6 <- newNode $ \rn6 -> DupNode Fanout (Level [rn6]) mempty () () () + rn6 <- newNode $ const $ DupNode 0 mempty () () () rn7 <- newNode $ const $ Branch1Node lvl opc () () rn8 <- newNode $ const $ AppNode () () () linkNodes (Ref rn4 1) (Ref rn6 1) @@ -502,44 +527,44 @@ reduceNode (Branch3PNode lvl opc _ r0 r1) (AppNode _ r2 r3) = do linkNodes r3 $ Ref rn8 2 reduceNode n0@AppNode {} n1@Branch3PNode {} = reduceNode n1 n0 -- FFI Duplication -reduceNode (DupNode Fanout _ re _ r0 r1) (OperandNode op _) +reduceNode (DupNode _ re _ r0 r1) (OperandNode op _) = copyIO1 r0 r1 OperandNode B.renameOp re op reduceNode n0@OperandNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanin lvl re _ r0 r1) (OperandPNode opp _ r2) - = copyIO2 Fanin lvl r0 r1 r2 OperandPNode (fmap . B.renameOp) re opp +reduceNode (DupNode lvl re _ r0 r1) (OperandPNode opp _ r2) + = copyIO2 lvl r0 r1 r2 OperandPNode (fmap . B.renameOp) re opp reduceNode n0@OperandPNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanin lvl re _ r0 r1) (IOPNode iop _ r2) - = copyIO2 Fanin lvl r0 r1 r2 IOPNode (fmap . B.renameInstr) re iop +reduceNode (DupNode lvl re _ r0 r1) (IOPNode iop _ r2) + = copyIO2 lvl r0 r1 r2 IOPNode (fmap . B.renameInstr) re iop reduceNode n0@IOPNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanout lvl re _ r0 r1) (IOContNode nbs _ r2) +reduceNode (DupNode lvl re _ r0 r1) (IOContNode nbs _ r2) = shareIOCont lvl re nbs r0 r1 r2 reduceNode n0@IOContNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanin lvl re _ r0 r1) (Pure0Node _ r2) - = commute1 (DupNode Fanin lvl re) Pure0Node r0 r1 r2 +reduceNode (DupNode lvl re _ r0 r1) (Pure0Node _ r2) + = commute1 (DupNode lvl re) Pure0Node r0 r1 r2 reduceNode n0@Pure0Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanin lvl re _ r0 r1) (Bind0Node _ r2) - = commute1 (DupNode Fanin lvl re) Bind0Node r0 r1 r2 +reduceNode (DupNode lvl re _ r0 r1) (Bind0Node _ r2) + = commute1 (DupNode lvl re) Bind0Node r0 r1 r2 reduceNode n0@Bind0Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanin lvl re _ r0 r1) (Bind1Node nbs _ r2) +reduceNode (DupNode lvl re _ r0 r1) (Bind1Node nbs _ r2) = shareBind1 lvl re nbs r0 r1 r2 reduceNode n0@Bind1Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanin lvl0 re _ r0 r1) (Branch0Node lvl1 _ r2) - = commute1 (DupNode Fanin lvl0 re) (Branch0Node lvl1) r0 r1 r2 +reduceNode (DupNode lvl0 re _ r0 r1) (Branch0Node lvl1 _ r2) + = commute1 (DupNode lvl0 re) (Branch0Node lvl1) r0 r1 r2 reduceNode n0@Branch0Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanin lvl0 re _ r0 r1) (Branch1Node lvl1 op _ r2) - = copyIO2 Fanin lvl0 r0 r1 r2 (Branch1Node lvl1) B.renameOp re op +reduceNode (DupNode lvl0 re _ r0 r1) (Branch1Node lvl1 op _ r2) + = copyIO2 lvl0 r0 r1 r2 (Branch1Node lvl1) B.renameOp re op reduceNode n0@Branch1Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanin lvl0 re _ r0 r1) (Branch2BNode lvl1 opc nbt _ r2 r3) +reduceNode (DupNode lvl0 re _ r0 r1) (Branch2BNode lvl1 opc nbt _ r2 r3) = shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 reduceNode n0@Branch2BNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanin lvl0 re _ r0 r1) (Branch2PNode lvl1 op _ r2 r3) - = commute2' (DupNode Fanout lvl0 re) (DupNode Fanin lvl0 re) +reduceNode (DupNode lvl0 re _ r0 r1) (Branch2PNode lvl1 op _ r2 r3) + = commute2' (DupNode lvl0 re) (DupNode lvl0 re) (Branch2PNode lvl1 $ B.renameOp (M.map fst re) op) (Branch2PNode lvl1 $ B.renameOp (M.map snd re) op) r0 r1 r2 r3 reduceNode n0@Branch2PNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode Fanout lvl0 re _ r0 r1) (Branch3PNode lvl1 op _ r2 r3) - = commute2' (DupNode Fanout lvl0 re) (DupNode Fanout lvl0 re) +reduceNode (DupNode lvl0 re _ r0 r1) (Branch3PNode lvl1 op _ r2 r3) + = commute2' (DupNode lvl0 re) (DupNode lvl0 re) (Branch3PNode lvl1 $ B.renameOp (M.map fst re) op) (Branch3PNode lvl1 $ B.renameOp (M.map snd re) op) r0 r1 r2 r3 @@ -570,10 +595,72 @@ reduceNode n0@DeadNode {} n1@Branch2PNode {} = reduceNode n1 n0 reduceNode (Branch3PNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@Branch3PNode {} = reduceNode n1 n0 -- FFI Book-keeping +reduceNode (RootNode name args _) (BoxNode _ _ r0) + = propagate1 r0 $ RootNode name args +reduceNode n0@BoxNode {} n1@RootNode {} = reduceNode n1 n0 +reduceNode (OperandNode op _) (BoxNode _ _ r0) + = propagate1 r0 $ OperandNode op +reduceNode n0@BoxNode {} n1@OperandNode {} = reduceNode n1 n0 +reduceNode (OperandPNode opp _ r0) (BoxNode lvl _ r1) + = commute0 (OperandPNode opp) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@OperandPNode {} = reduceNode n1 n0 +reduceNode (IONode b _) (BoxNode _ _ r0) + = propagate1 r0 $ IONode b +reduceNode n0@BoxNode {} n1@IONode {} = reduceNode n1 n0 +reduceNode (IOPNode iop _ r0) (BoxNode lvl _ r1) + = commute0 (IOPNode iop) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@IOPNode {} = reduceNode n1 n0 +reduceNode (IOContNode nbs _ r0) (BoxNode lvl _ r1) + = commute0 (IOContNode nbs) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@IOContNode {} = reduceNode n1 n0 +reduceNode (Pure0Node _ r0) (BoxNode lvl _ r1) + = commute0 Pure0Node (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@Pure0Node {} = reduceNode n1 n0 +reduceNode (Bind0Node _ r0) (BoxNode lvl _ r1) + = commute0 Bind0Node (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@Bind0Node {} = reduceNode n1 n0 +reduceNode (Bind1Node nbs _ r0) (BoxNode lvl _ r1) + = commute0 (Bind1Node nbs) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@Bind1Node {} = reduceNode n1 n0 +reduceNode (Branch0Node lvl0 _ r0) (BoxNode lvl1 _ r1) = commute0 + (Branch0Node $ if lvl0 < lvl1 then lvl0 else succ lvl0) (BoxNode lvl1) r0 r1 +reduceNode n0@BoxNode {} n1@Branch0Node {} = reduceNode n1 n0 +reduceNode (Branch1Node lvl0 op _ r0) (BoxNode lvl1 _ r1) = commute0 + (Branch1Node (if lvl0 < lvl1 then lvl0 else succ lvl0) op) + (BoxNode lvl1) + r0 r1 +reduceNode n0@BoxNode {} n1@Branch1Node {} = reduceNode n1 n0 +reduceNode (Branch2BNode lvl0 opc nbt _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (Branch2BNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc nbt) + (BoxNode lvl1) + r0 r1 r2 +reduceNode n0@BoxNode {} n1@Branch2BNode {} = reduceNode n1 n0 +reduceNode (Branch2PNode lvl0 opc _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (Branch2PNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc) + (BoxNode lvl1) + r0 r1 r2 +reduceNode n0@BoxNode {} n1@Branch2PNode {} = reduceNode n1 n0 +reduceNode (Branch3PNode lvl0 opc _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (Branch3PNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc) + (BoxNode lvl1) + r0 r1 r2 +reduceNode n0@BoxNode {} n1@Branch3PNode {} = reduceNode n1 n0 reduceNode n0 n1 = error . show $ "unexpected node pairing" <> line <> pretty n0 <> line <> pretty n1 {-# INLINABLE reduceNode #-} +commute0 + :: HasRewriter sig m + => (() -> () -> INetF ()) -> (() -> () -> INetF ()) + -> Ref -> Ref -> m () +commute0 mk1 mk2 r0 r1 = do + rn3 <- newNode $ const $ mk2 () () + rn4 <- newNode $ const $ mk1 () () + linkNodes (Ref rn3 1) (Ref rn4 1) + linkNodes r0 $ Ref rn3 0 + linkNodes r1 $ Ref rn4 0 +{-# INLINABLE commute0 #-} + commute1 :: HasRewriter sig m => (() -> () -> () -> INetF ()) -> (() -> () -> INetF ()) @@ -597,6 +684,14 @@ commute1' mk1 mk2a mk2b r0 r1 r2 = do linkNodes r2 $ Ref rn5 0 {-# INLINABLE commute1' #-} +commute2 + :: HasRewriter sig m + => (() -> () -> () -> INetF ()) + -> (() -> () -> () -> INetF ()) + -> Ref -> Ref -> Ref -> Ref -> m () +commute2 mk1 mk2 = commute2' mk1 mk1 mk2 mk2 +{-# INLINABLE commute2 #-} + commute2' :: HasRewriter sig m => (() -> () -> () -> INetF ()) @@ -641,22 +736,21 @@ copyIO1 r0 r1 mk1 f re ffi = do copyIO2 :: HasRewriter sig m - => DupKind -> Level -> Ref -> Ref -> Ref -> (a -> () -> () -> INetF ()) + => Level -> Ref -> Ref -> Ref -> (a -> () -> () -> INetF ()) -> (M.Map B.Name B.Operand -> a -> a) -> Renames -> a -> m () -copyIO2 dk lvl r0 r1 r2 mk1 f re ffi = commute1' (DupNode dk lvl re) +copyIO2 lvl r0 r1 r2 mk1 f re ffi = commute1' (DupNode lvl re) (mk1 $ f (M.map fst re) ffi) (mk1 $ f (M.map snd re) ffi) r0 r1 r2 {-# INLINABLE copyIO2 #-} copyIO3 :: HasRewriter sig m - => DupKind -> DupKind -> Level -> Ref -> Ref -> Ref -> Ref - -> (a -> () -> () -> () -> INetF ()) + => Level -> Ref -> Ref -> Ref -> Ref -> (a -> () -> () -> () -> INetF ()) -> (M.Map B.Name B.Operand -> a -> a) -> Renames -> a -> m () -copyIO3 dk1 dk2 lvl r0 r1 r2 r3 mk1 f re ffi = commute2' - (DupNode dk1 lvl re) (DupNode dk2 lvl re) +copyIO3 lvl r0 r1 r2 r3 mk1 f re ffi = commute2' + (DupNode lvl re) (DupNode lvl re) (mk1 $ f (M.map fst re) ffi) (mk1 $ f (M.map snd re) ffi) r0 r1 r2 r3 @@ -665,17 +759,16 @@ copyIO3 dk1 dk2 lvl r0 r1 r2 r3 mk1 f re ffi = commute2' shareIOCont :: HasRewriter sig m => Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () -shareIOCont = sharePreaction (<>) (pure pure) (pure pure) IOContNode Fanout +shareIOCont = sharePreaction (<>) (pure pure) (pure pure) IOContNode {-# INLINABLE shareIOCont #-} shareBind1 :: HasRewriter sig m => Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () -shareBind1 lvl - = sharePreaction (const id) (wrap fst) (wrap snd) Bind1Node Fanin lvl +shareBind1 lvl = sharePreaction (const id) (wrap fst) (wrap snd) Bind1Node lvl where wrap sel re r0 = do - rn1 <- newNode $ const $ DupNode Fanout lvl re () () () + rn1 <- newNode $ const $ DupNode lvl re () () () rn2 <- newNode $ const $ DeadNode () linkNodes (Ref rn1 $ sel (2, 1)) (Ref rn2 0) linkNodes r0 $ Ref rn1 $ sel (1, 2) @@ -687,15 +780,15 @@ shareBranch2B => Level -> Level -> Renames -> B.Operand -> Preaction -> Ref -> Ref -> Ref -> Ref -> m () shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 = case sharePreaction' nbt of - Nothing -> copyIO3 Fanout Fanin lvl0 r0 r1 r2 r3 mk renamePreaction re nbt + Nothing -> copyIO3 lvl0 r0 r1 r2 r3 mk renamePreaction re nbt Just (name, sb) | null (B.bodyInstrs sb) -> do let mkPreaction rn = SimplePreaction (mkName rn) sb rn4 <- newNode $ \rn4 -> mk (mkPreaction rn4) () () () rn5 <- newNode $ \rn5 -> mk (mkPreaction rn5) () () () let re' = M.singleton name (mkRef t rn4, mkRef t rn5) t = B.instrType $ B.bodyTerm sb - rn6 <- newNode $ const $ DupNode Fanout lvl0 re () () () - rn7 <- newNode $ const $ DupNode Fanin lvl0 re () () () + rn6 <- newNode $ const $ DupNode lvl0 re () () () + rn7 <- newNode $ const $ DupNode lvl0 re () () () r8 <- w1 re' $ Ref rn4 0 r9 <- w2 re' $ Ref rn5 0 linkNodes (Ref rn4 1) (Ref rn6 1) @@ -729,8 +822,8 @@ shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 = case sharePreaction' nbt of rn6 <- newNode $ \rn6 -> mk (mkPreact fst rn6) () () () rn7 <- newNode $ \rn7 -> mk (mkPreact snd rn7) () () () let re' = M.fromList $ zipWith (dupNames gop ltt rn5 rn6) [0..] names - rn8 <- newNode $ const $ DupNode Fanout lvl0 re () () () - rn9 <- newNode $ const $ DupNode Fanin lvl0 re () () () + rn8 <- newNode $ const $ DupNode lvl0 re () () () + rn9 <- newNode $ const $ DupNode lvl0 re () () () r10 <- w1 re' (Ref rn6 0) r11 <- w2 re' (Ref rn7 0) linkNodes (Ref rn4 0) (Ref rn5 0) @@ -748,7 +841,7 @@ shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 = case sharePreaction' nbt of w2 = wrap snd wrap sel re' r4 = do - rn5 <- newNode $ const $ DupNode Fanout lvl0 re' () () () + rn5 <- newNode $ const $ DupNode lvl0 re' () () () rn6 <- newNode $ const $ DeadNode () linkNodes (Ref rn5 $ sel (2, 1)) (Ref rn6 0) linkNodes r4 $ Ref rn5 $ sel (1, 2) @@ -766,16 +859,16 @@ sharePreaction => (Renames -> Renames -> Renames) -> (Renames -> Ref -> m Ref) -> (Renames -> Ref -> m Ref) -> (Preaction -> () -> () -> INetF ()) - -> DupKind -> Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () -sharePreaction append w1 w2 mk dk lvl re nbs r0 r1 r2 = case sharePreaction' nbs of - Nothing -> copyIO2 dk lvl r0 r1 r2 mk renamePreaction re nbs + -> Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () +sharePreaction append w1 w2 mk lvl re nbs r0 r1 r2 = case sharePreaction' nbs of + Nothing -> copyIO2 lvl r0 r1 r2 mk renamePreaction re nbs Just (name, sb) | null (B.bodyInstrs sb) -> do let mkPreaction rn = SimplePreaction (mkName rn) sb rn3 <- newNode $ \rn3 -> mk (mkPreaction rn3) () () rn4 <- newNode $ \rn4 -> mk (mkPreaction rn4) () () let re' = M.singleton name (mkRef t rn3, mkRef t rn4) t = B.instrType $ B.bodyTerm sb - rn5 <- newNode $ const $ DupNode dk lvl (append re' re) () () () + rn5 <- newNode $ const $ DupNode lvl (append re' re) () () () r6 <- w1 re' $ Ref rn3 0 r7 <- w2 re' $ Ref rn4 0 linkNodes (Ref rn3 1) (Ref rn5 1) @@ -806,7 +899,7 @@ sharePreaction append w1 w2 mk dk lvl re nbs r0 r1 r2 = case sharePreaction' nbs rn5 <- newNode $ \rn5 -> mk (mkPreact fst rn5) () () rn6 <- newNode $ \rn6 -> mk (mkPreact snd rn6) () () let re' = M.fromList $ zipWith (dupNames gop ltt rn5 rn6) [0..] names - rn7 <- newNode $ const $ DupNode dk lvl (append re' re) () () () + rn7 <- newNode $ const $ DupNode lvl (append re' re) () () () r8 <- w1 re' (Ref rn5 0) r9 <- w2 re' (Ref rn6 0) linkNodes (Ref rn3 0) (Ref rn4 0) diff --git a/test/Golden.hs b/test/Golden.hs index 8b27523..aa8c8fa 100644 --- a/test/Golden.hs +++ b/test/Golden.hs @@ -12,7 +12,7 @@ module Golden where import Control.Algebra (Algebra(alg), Has, (:+:)(L, R), run) -import Control.Carrier.Reader (ReaderC(ReaderC)) +import Control.Carrier.Reader (ReaderC(ReaderC), runReader) import Control.Carrier.State.Church (State, evalState, get, gets, modify) import Control.Lens (Iso', iso, ix, (^?), (%~)) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -113,6 +113,7 @@ compileFile file = runGolden $ \lh -> do $ evalState @INetPairs mempty $ evalState @INetSize 0 $ evalState @Count 0 + $ runReader @Level 0 $ runTraceRewrite <*> m $ lh printDiags :: DiagnosisC Diagnostic Identity a -> a diff --git a/test/Golden/CataStaticDouble.elem b/test/Golden/CataStaticDouble.elem index 01a4695..f360087 100644 --- a/test/Golden/CataStaticDouble.elem +++ b/test/Golden/CataStaticDouble.elem @@ -6,40 +6,16 @@ main = count @(IO (∀ 0 → 0)) (λ(∀ 0 → (IO (∀ 0 → 0) → 0) → 0) 0 @(IO (∀ 0 → 0)) (pureIO @(∀ 0 → 0) (Λ λ0 0)) (λ(IO (∀ 0 → 0)) bindIO @(∀ 0 → 0) 0 @(∀ 0 → 0) (λ(∀ 0 → 0) c_dothing)) - -- (λ(IO (∀ 0 → 0)) 0) ) count = double (double (succ zero)) --- count = double (succ (succ2 zero)) --- count = double (Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 --- ((λ((∀ 0 → (2 → 0) → 0) → 1) 0 (Λ λ0 λ(2 → 0) 0 (2 (Λ λ0 λ(3 → 0) 1)))) 2))) --- count = double (Λ λ((∀ 0 → (1 → 0) → 0) → 0) --- (λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (2 (Λ λ0 λ(2 → 0) 1)))) 0) - --- count = double count1 --- count1 = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (2 (Λ λ0 λ(2 → 0) 0 (4 (Λ λ0 λ(3 → 0) 1))))) double = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (λ(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 1 succ) - -- 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 1 (λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 0)) zero = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 1) succ = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (3 @1 2)) -{- -succ2 = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (3 @1 2)) --} - -{- - succ zero = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (2 (Λ λ0 λ(1 → 0) 1))) - succ (succ zero) = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (succ zero @1 2)) - - double = \a -> a (\b -> b a (\c -> c)) - -- count = double (\a -> a (\_ b -> b ((\c -> c (\_ d -> d (c (\e _ -> e)))) a))) - count = double (\a -> (\b -> b (\_ c -> c (b (\d _ -> d)))) a) - double has level 83 - count has level 92 --} foreign primitive pureIO : ∀ 0 → IO 0 foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 diff --git a/test/Golden/NestedBranch2.opt.ll b/test/Golden/NestedBranch2.opt.ll index 23f59b1..70e08b3 100644 --- a/test/Golden/NestedBranch2.opt.ll +++ b/test/Golden/NestedBranch2.opt.ll @@ -3,7 +3,7 @@ source_filename = "test/Golden/NestedBranch2.elem" declare void @dothing(i4) local_unnamed_addr -define private fastcc void @"570"(i4) unnamed_addr { +define private fastcc void @"7252"(i4) unnamed_addr { tail call void @dothing(i4 %0) tail call void @dothing(i4 %0) ret void @@ -14,7 +14,7 @@ define void @main(i4) local_unnamed_addr { br i1 %2, label %3, label %.sink.split .sink.split: ; preds = %1 - tail call fastcc void @"570"(i4 %0) + tail call fastcc void @"7252"(i4 %0) br label %3 3: ; preds = %1, %.sink.split diff --git a/test/Golden/NestedBranch3.opt.ll b/test/Golden/NestedBranch3.opt.ll index 1f08031..f94df3c 100644 --- a/test/Golden/NestedBranch3.opt.ll +++ b/test/Golden/NestedBranch3.opt.ll @@ -3,7 +3,7 @@ source_filename = "test/Golden/NestedBranch3.elem" declare i2 @dothing() local_unnamed_addr -define private fastcc void @"411"() unnamed_addr { +define private fastcc void @"2938"() unnamed_addr { %1 = tail call i2 @dothing() ret void } @@ -14,7 +14,7 @@ define i1 @main() local_unnamed_addr { br i1 %2, label %3, label %.sink.split .sink.split: ; preds = %0 - tail call fastcc void @"411"() + tail call fastcc void @"2938"() br label %3 3: ; preds = %0, %.sink.split diff --git a/test/Golden/ShareIO.opt.ll b/test/Golden/ShareIO.opt.ll index 8cde567..e90fe07 100644 --- a/test/Golden/ShareIO.opt.ll +++ b/test/Golden/ShareIO.opt.ll @@ -5,7 +5,7 @@ declare void @putbit(i1) local_unnamed_addr declare i1 @getbit() local_unnamed_addr -define private fastcc { i1, i1 } @"233"() unnamed_addr { +define private fastcc { i1, i1 } @"2564"() unnamed_addr { %1 = tail call i1 @getbit() %2 = tail call i1 @getbit() %3 = insertvalue { i1, i1 } zeroinitializer, i1 %2, 1 @@ -14,7 +14,7 @@ define private fastcc { i1, i1 } @"233"() unnamed_addr { } define void @main1() local_unnamed_addr { - %1 = tail call fastcc { i1, i1 } @"233"() + %1 = tail call fastcc { i1, i1 } @"2564"() %2 = extractvalue { i1, i1 } %1, 1 %3 = extractvalue { i1, i1 } %1, 0 %4 = xor i1 %3, %2 @@ -23,7 +23,7 @@ define void @main1() local_unnamed_addr { } define void @main2() local_unnamed_addr { - %1 = tail call fastcc { i1, i1 } @"233"() + %1 = tail call fastcc { i1, i1 } @"2564"() %2 = extractvalue { i1, i1 } %1, 1 %3 = extractvalue { i1, i1 } %1, 0 %4 = xor i1 %3, %2 diff --git a/test/Golden/SimpleArgs.opt.ll b/test/Golden/SimpleArgs.opt.ll index d884c87..00ecb3a 100644 --- a/test/Golden/SimpleArgs.opt.ll +++ b/test/Golden/SimpleArgs.opt.ll @@ -2,13 +2,13 @@ source_filename = "test/Golden/SimpleArgs.elem" ; Function Attrs: norecurse nounwind readnone -define i1 @snd(i1, i1 returned) local_unnamed_addr #0 { - ret i1 %1 +define i1 @main(i1 returned) local_unnamed_addr #0 { + ret i1 %0 } ; Function Attrs: norecurse nounwind readnone -define i1 @main(i1 returned) local_unnamed_addr #0 { - ret i1 %0 +define i1 @snd(i1, i1 returned) local_unnamed_addr #0 { + ret i1 %1 } attributes #0 = { norecurse nounwind readnone } From b33e351d1f687d11c7ad8a6e055f4d0c5acfc701 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Thu, 23 Jun 2022 22:50:56 +0100 Subject: [PATCH 08/17] Avoid propagating branches through expressions Switch to a CPS ruleset where branches can be applied directly to the IO continuation. Perform all marshalling in IO, as required by the new rewrite rules. Change the backend representation to use labelled blocks instead of nested blocks. Avoid collisions between user-defined exported functions and compiler-generated private functions used for sharing IO. --- src/Language/Elemental/AST/Expr.hs | 186 ++- src/Language/Elemental/Backend.hs | 332 ++-- src/Language/Elemental/Backend/LLVM.hs | 249 ++- src/Language/Elemental/Emit.hs | 102 +- src/Language/Elemental/InteractionNet.hs | 1337 ++++++++------- src/Language/Elemental/Pretty.hs | 10 +- test/Golden.hs | 195 ++- test/Golden/Arithmetic.elem | 97 ++ test/Golden/Arithmetic.opt.ll | 13 + test/Golden/BitOrder.opt.ll | 13 +- test/Golden/BranchIO.elem | 7 + test/Golden/BranchIO.opt.ll | 18 + test/Golden/CallOrder.opt.ll | 57 +- test/Golden/CataDynamic.opt.ll | 8 +- test/Golden/CataStaticAccum.elem | 27 + test/Golden/CataStaticAccum.opt.ll | 14 + test/Golden/EchoChar.opt.ll | 1917 +++++++++++++++++++++- test/Golden/ForeignNames.opt.ll | 8 +- test/Golden/FunctionInIO.opt.ll | 7 +- test/Golden/MemoryBit.opt.ll | 10 +- test/Golden/NestedBranch.opt.ll | 12 +- test/Golden/NestedBranch2.elem | 31 +- test/Golden/NestedBranch2.opt.ll | 21 +- test/Golden/NestedBranch3.opt.ll | 19 +- test/Golden/ShareBindCont.opt.ll | 4 +- test/Golden/ShareIO.opt.ll | 28 +- test/Golden/ShareIOPoly.elem | 17 + test/Golden/ShareIOPoly.opt.ll | 19 + test/Main.hs | 3 +- 29 files changed, 3785 insertions(+), 976 deletions(-) create mode 100644 test/Golden/Arithmetic.elem create mode 100644 test/Golden/Arithmetic.opt.ll create mode 100644 test/Golden/BranchIO.elem create mode 100644 test/Golden/BranchIO.opt.ll create mode 100644 test/Golden/CataStaticAccum.elem create mode 100644 test/Golden/CataStaticAccum.opt.ll create mode 100644 test/Golden/ShareIOPoly.elem create mode 100644 test/Golden/ShareIOPoly.opt.ll diff --git a/src/Language/Elemental/AST/Expr.hs b/src/Language/Elemental/AST/Expr.hs index e4dab6e..4d9c190 100644 --- a/src/Language/Elemental/AST/Expr.hs +++ b/src/Language/Elemental/AST/Expr.hs @@ -53,6 +53,7 @@ module Language.Elemental.AST.Expr , exprType , IncrementAll , sIncrementAll + , sIncrementAll' , SubstituteAll , sSubstituteAll , incrementExpr @@ -125,8 +126,9 @@ data Expr tscope scope t where BackendIO :: SBackendType lt -- -> (forall sig m. Has IRBuilder sig m => m (BackendOperandType lt)) - -> Backend.Body + -> Backend.Instruction -> Expr tscope scope ('IOType ('BackendType lt)) + -- TODO: Merge with v'Call'. BackendPIO :: SBackendType lta -> SBackendType lt -> (Backend.Operand -> Backend.Instruction) @@ -141,7 +143,7 @@ data Expr tscope scope t where StorePointer :: Expr tscope scope StorePointerType -- | A call of a foreign function. This is an internal expression. Call - :: AllIsOpType ltargs ~ 'True => Backend.Name + :: AllIsOpType ltargs ~ 'True => Backend.ForeignName -> SList SBackendType ltargs -> SBackendType ltret -> Expr tscope scope (BuildForeignType ltargs ltret) -- | Extracts a single bit from an integer. This is an internal expression. @@ -158,7 +160,7 @@ data Expr tscope scope t where ) -- | Converts an @i1@ into a 'BitType'. This is an internal expression. TestBit :: Expr tscope scope - ('BackendType ('BackendInt ('Succ 'Zero)) :-> BitType) + ('BackendType ('BackendInt ('Succ 'Zero)) :-> 'IOType BitType) -- | Pointer addresses in the AST. newtype Address = Address { getAddress :: Natural } @@ -247,16 +249,38 @@ class AllIsOpType (ForeignArgs t) ~ 'True => HasForeignType t where -- | Singleton version of 'ForeignRet'. sForeignRet :: SType tscope t -> SBackendType (ForeignRet t) + -- | The return t'Type' of the Elemental type. + type InternalRet t :: Type + + -- | Singleton version of 'InternalRet'. + sInternalRet :: SType tscope t -> SType tscope (InternalRet t) + -- | Wraps the foreign type into the native type. wrapImport - :: SNat tscope -> SList (SType tscope) scope - -> SType tscope t -> Expr tscope scope (ForeignType t) - -> Expr tscope scope t - + :: SNat tscope -> SList (SType tscope) scope -> SType tscope t + -> Expr tscope scope (ForeignType t) -> Expr tscope scope t + -- | Wraps the native type into the foreign type. wrapExport - :: SNat tscope -> SList (SType tscope) scope - -> SType tscope t -> Expr tscope scope t + :: SNat tscope -> SList (SType tscope) scope -> SType tscope t + -> Expr tscope scope t -> Expr tscope scope (ForeignType t) + + -- | Lifts an IO bind into the foreign type. + bindImport + :: SNat tscope -> SList (SType tscope) scope -> SType tscope t + -> Expr tscope scope ('IOType tx) + -> (forall scope'. SList (SType tscope) scope' + -> (forall tr. Expr tscope scope tr -> Expr tscope scope' tr) + -> Expr tscope scope' tx -> Expr tscope scope' t) + -> Expr tscope scope t + + -- | Lifts an IO bind into the foreign type. + bindExport + :: SNat tscope -> SList (SType tscope) scope -> SType tscope t + -> Expr tscope scope ('IOType tx) + -> (forall scope'. SList (SType tscope) scope' + -> (forall tr. Expr tscope scope tr -> Expr tscope scope' tr) + -> Expr tscope scope' tx -> Expr tscope scope' (ForeignType t)) -> Expr tscope scope (ForeignType t) instance MarshallableType t => HasForeignType ('IOType t) where @@ -266,11 +290,14 @@ instance MarshallableType t => HasForeignType ('IOType t) where type ForeignRet ('IOType t) = Marshall t sForeignRet (SIOType t) = sMarshall t - wrapImport tscope scope (SIOType t) x = BindIO :@ t' :$ x :@ t :$ (t' - :\ PureIO :@ t - :$ marshallIn tscope (t' :^ scope) t (Var SZero)) + type InternalRet ('IOType t) = t + sInternalRet (SIOType t) = t + + wrapImport tscope scope (SIOType t) x = BindIO + :@ bt :$ x + :@ t :$ (bt :\ marshallIn tscope (bt :^ scope) t (Var SZero)) where - t' = SBackendType $ sMarshall t + bt = SBackendType $ sMarshall t wrapExport tscope scope (SIOType (t :: SType tscope tx)) x = withProof (subIncElim tscope SZero t' t Refl) @@ -280,6 +307,25 @@ instance MarshallableType t => HasForeignType ('IOType t) where t' :: SType tscope ('BackendType (Marshall tx)) t' = SBackendType $ sMarshall t + bindImport tscope scope (SIOType t) ex cont + = withProof (subIncElim tscope SZero t (SIOType tx) Refl) + $ withProof (insZeroP tx scope) + $ BindIO :@ tx :$ ex :@ t :$ (tx :\ cont (tx :^ scope) + (incrementExpr tscope scope SZero tx) (Var SZero)) + where + SIOType tx = exprType tscope scope ex + + bindExport tscope scope (SIOType (t :: SType tscope t)) ex cont + = withProof (subIncElim tscope SZero t' (SIOType tx) Refl) + $ withProof (insZeroP tx scope) + $ BindIO :@ tx :$ ex :@ t' :$ (tx :\ cont (tx :^ scope) + (incrementExpr tscope scope SZero tx) (Var SZero)) + where + SIOType tx = exprType tscope scope ex + + t' :: SType tscope ('BackendType (Marshall t)) + t' = SBackendType $ sMarshall t + instance (MarshallableType tx, IsOpType (Marshall tx) ~ 'True , HasForeignType ty) => HasForeignType (tx :-> ty) where @@ -289,20 +335,41 @@ instance (MarshallableType tx, IsOpType (Marshall tx) ~ 'True type ForeignRet (_ :-> ty) = ForeignRet ty sForeignRet (SArrow _ ty) = sForeignRet ty + type InternalRet (_ :-> ty) = InternalRet ty + sInternalRet (SArrow _ ty) = sInternalRet ty + wrapImport tscope scope (SArrow tx ty) x = tx :\ wrapImport tscope (tx :^ scope) ty ( withProof (insZeroP tx scope) $ incrementExpr tscope scope SZero tx x :$ marshallOut tscope (tx :^ scope) tx (Var SZero) ) - - wrapExport tscope scope (SArrow tx ty) x = tx' - :\ wrapExport tscope (tx' :^ scope) ty - (withProof (insZeroP tx' scope) - $ incrementExpr tscope scope SZero tx' x - :$ marshallIn tscope (tx' :^ scope) tx (Var SZero) - ) + + wrapExport tscope scope (SArrow tx ty) ex = withProof (insZeroP tx' scope) + $ tx' :\ bindExport tscope scope' ty + (marshallIn tscope scope' tx $ Var SZero) + (\sc inc ey -> wrapExport tscope sc ty + $ inc (incrementExpr tscope scope SZero tx' ex) :$ ey) + where + tx' = SBackendType $ sMarshall tx + scope' = tx' :^ scope + + bindImport tscope scope (SArrow tx ty) ex ef = withProof (insZeroP tx scope) + $ tx :\ bindImport tscope (tx :^ scope) ty + (incrementExpr tscope scope SZero tx ex) + (\scope' inc' ey + -> ef scope' (inc' . incrementExpr tscope scope SZero tx) ey + :$ inc' (Var SZero)) + + bindExport tscope scope (SArrow (tx :: SType tscope tx) ty) ex ef + = withProof (insZeroP tx' scope) + $ tx' :\ bindExport tscope (tx' :^ scope) ty + (incrementExpr tscope scope SZero tx' ex) + (\scope' inc' ey + -> ef scope' (inc' . incrementExpr tscope scope SZero tx') ey + :$ inc' (Var SZero)) where + tx' :: SType tscope ('BackendType (Marshall tx)) tx' = SBackendType $ sMarshall tx -- | The foreign type corresponding to a native type. @@ -339,7 +406,7 @@ class t ~ Unmarshall (Marshall t) => MarshallableType t where marshallIn :: SNat tscope -> SList (SType tscope) scope -> SType tscope t -> Expr tscope scope ('BackendType (Marshall t)) - -> Expr tscope scope t + -> Expr tscope scope ('IOType t) -- | Marshalls an expression from the native type to the t'BackendType'. marshallOut @@ -361,9 +428,9 @@ instance MarshallableType UnitType where type Marshall UnitType = 'BackendInt 'Zero sMarshall _ = SBackendInt SZero - marshallIn _ _ _ _ = TypeLam $ STypeVar SZero :\ Var SZero + marshallIn _ _ _ _ + = PureIO :@ SUnitType :$ TypeLam (STypeVar SZero :\ Var SZero) - -- marshallOut _ _ _ _ = BackendOperand (SBackendInt SZero) Backend.Empty marshallOut _ _ _ = (:$ BackendOperand (SBackendInt SZero) Backend.Empty) . (:@ SBackendType (SBackendInt SZero)) @@ -394,33 +461,48 @@ instance (t ~ BitTuple (ArgCount t), ArgCount t ~ 'Succ _n) = 'BackendInt ('Succ (ArgCount t)) sMarshall (SForall (SArrow t _)) = SBackendInt $ sArgCount t - marshallIn tscope scope t x = TypeLam $ tx :\ withProof (ltSucc size) - ( withProof (insZeroP tx scope') - $ marshallTuple (SSucc tscope) (tx :^ scope') size size - ( withProof (insZeroP tx scope') - $ incrementExpr (SSucc tscope) scope' SZero tx - $ incrementExprType tscope scope SZero x - ) - $ Var SZero - ) + marshallIn tscope scope t x = withProof (ltSucc size) + $ marshallTuple tscope scope size size t x $ \_ _ cont + -> PureIO :@ t :$ TypeLam (tx :\ cont (Var SZero)) where size = sArgCount tx SForall (SArrow tx _) = t - scope' = sIncrementAll tscope SZero scope marshallTuple - :: forall tscope scope n size. (CmpNat n ('Succ size) ~ 'LT) - => SNat ('Succ tscope) -> SList (SType ('Succ tscope)) scope - -> SNat n -> SNat size - -> Expr ('Succ tscope) scope ('BackendType ('BackendInt size)) - -> Expr ('Succ tscope) scope (BitTuple n) - -> Expr ('Succ tscope) scope ('TypeVar 'Zero) - marshallTuple _ _ SZero _ _ er = er - marshallTuple tsc sc (SSucc idx) size' ex er - = withProof (ltSuccLToLT idx (SSucc size') Refl) - $ marshallTuple tsc sc idx size' ex - $ er :$ marshallIn tsc sc SBitType (IsolateBit idx size' :$ ex) - + :: forall tscope scope n size tr. (CmpNat n ('Succ size) ~ 'LT) + => SNat tscope -> SList (SType tscope) scope + -> SNat n -> SNat size -> SType tscope tr + -> Expr tscope scope ('BackendType ('BackendInt size)) + -> (forall scope'. SList (SType tscope) scope' + -> (forall tx. Expr ('Succ tscope) (IncrementAll 'Zero scope) tx + -> Expr ('Succ tscope) + (BitTuple size ': IncrementAll 'Zero scope') tx) + -> (Expr ('Succ tscope) + (BitTuple size ': IncrementAll 'Zero scope') (BitTuple n) + -> Expr ('Succ tscope) + (BitTuple size ': IncrementAll 'Zero scope') + ('TypeVar 'Zero)) + -> Expr tscope scope' ('IOType tr)) + -> Expr tscope scope ('IOType tr) + marshallTuple tsc sc SZero size' _ _ cont + = withProof (insZeroP (sBitTuple size') + $ sIncrementAll tsc SZero sc) + $ cont sc (incrementExpr (SSucc tsc) (sIncrementAll tsc SZero sc) + SZero $ sBitTuple size') id + marshallTuple tsc sc (SSucc idx) size' tr ex cont = BindIO + :@ SBitType :$ marshallIn tsc sc SBitType + (IsolateBit idx size' :$ ex) + :@ tr :$ withProof (ltSuccLToLT idx (SSucc size') Refl) (withProof + (insZeroP SBitType $ sIncrementAll tsc SZero sc) + $ withProof (insZeroP SBitType sc) + $ SBitType + :\ marshallTuple tsc (SBitType :^ sc) idx size' tr + (incrementExpr tsc sc SZero SBitType ex) + (\sc' inc cont' -> cont sc' + (inc . incrementExpr (SSucc tsc) + (sIncrementAll tsc SZero sc) SZero SBitType) + $ \er -> cont' $ er :$ inc (Var SZero))) + marshallOut tscope scope t x = x :@ SBackendType (sMarshall t) :$ marshallTuple tscope scope size (const $ const id) where @@ -542,7 +624,7 @@ exprType tscope scope = \case InsertBit size -> SBackendType (SBackendInt $ SSucc SZero) :-> SBackendType (SBackendInt size) :-> SBackendType (SBackendInt (SSucc size)) - TestBit -> SBackendType (SBackendInt $ SSucc SZero) :-> SBitType + TestBit -> SBackendType (SBackendInt $ SSucc SZero) :-> SIOType SBitType -- | Increments every type in a list. type IncrementAll :: Nat -> [Type] -> [Type] @@ -554,9 +636,14 @@ type family IncrementAll idx ts where sIncrementAll :: SNat scope -> SNat idx -> SList (SType scope) ts -> SList (SType ('Succ scope)) (IncrementAll idx ts) -sIncrementAll _ _ SNil = SNil -sIncrementAll scope idx (t :^ ts) - = sIncrement scope idx t :^ sIncrementAll scope idx ts +sIncrementAll scope idx = sIncrementAll' (sIncrement scope idx) idx + +-- | Generalised version of 'sIncrementAll'. +sIncrementAll' + :: (forall t. proxy t -> proxy' (Increment idx t)) + -> SNat idx -> SList proxy ts -> SList proxy' (IncrementAll idx ts) +sIncrementAll' _ _ SNil = SNil +sIncrementAll' inc idx (t :^ ts) = inc t :^ sIncrementAll' inc idx ts -- | Substitutes every type in a list. type SubstituteAll :: Nat -> Type -> [Type] -> [Type] @@ -899,3 +986,4 @@ countBitTuple (SSucc size) = withProof (countBitTuple size) Refl {-# RULES "Proof/countBitTuple" countBitTuple = \_ -> Unsafe.unsafeCoerce Refl #-} {-# INLINE [1] countBitTuple #-} + diff --git a/src/Language/Elemental/Backend.hs b/src/Language/Elemental/Backend.hs index 03d6896..80879b3 100644 --- a/src/Language/Elemental/Backend.hs +++ b/src/Language/Elemental/Backend.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -11,69 +12,101 @@ module Language.Elemental.Backend ( Name(..) - , Named(..) + , Named + , FunctionName(..) + , NamedFunction + , ForeignName(..) + , ForeignNamed + , Named'(..) + , Label(..) , Type(..) , Bit(..) , Operand(..) , Instruction(..) - , Body(..) + , Terminator(..) + , _Return + , _TailCall + , Block(..) + , _entryBlock + , _namedBlocks + , IBlock(..) + , _IBlock + , BlockList(..) + , _blockInstrs + , _blockTerm + , NamedBlockList(..) , Function(..) + , _functionArgs + , _functionRet + , ImplicitFunction(..) + , _ifunctionBlocks , External(..) , Program(..) , opType , instrType - , concatBody -- * Partial , Partial(..) , FoldArrow , addOperand - -- * Renaming - , renameOp - , renameInstr - , renameBody -- * Traversals , opRefs , instrOps - , instrBodies - , bodyOps - , bodyBoundNames - , bodyFreeRefs + , termOps + , blockOps + , blockBoundNames + , blockFreeRefs + , blockListBlocks + , blockListBoundNames + , blockListFreeRefs ) where -import Control.Lens (Traversal', anyOf, (%~)) +import Control.Lens + ( Bifunctor, Iso', Lens', Prism', Traversal' + , anyOf, bimap, filtered, iso, lens, noneOf, prism + ) import Data.ByteString.Short (ShortByteString) import Data.DList (DList, snoc, toList) import Data.Foldable (foldl') +import Data.IntMap qualified as IM import Data.Kind qualified as Kind -import Data.Map qualified as M -import Data.Maybe (fromMaybe) import Data.String (IsString(fromString)) import Numeric.Natural (Natural) import Prettyprinter ( Doc, Pretty(pretty) , concatWith, encloseSep, flatAlt, group - , hardline, line, nest, parens, tupled + , hardline, indent, line, nest, parens, tupled , (<+>) ) import Language.Elemental.Singleton --- | Names for the operand namespace and the function namespace. -data Name - = Name Integer - | ExternalName ShortByteString - | SubName Name Integer - | UnusedName +-- | Names for the operand namespace. +newtype Name = Name Int + deriving stock (Eq, Ord, Read, Show) + deriving newtype (Pretty) + +-- | Names for the function namespace. +data FunctionName = PrivateName Name | ExternalName ForeignName deriving stock (Eq, Ord, Read, Show) -instance IsString Name where - fromString = ExternalName . fromString +instance Pretty FunctionName where + pretty (PrivateName n) = pretty n + pretty (ExternalName n) = pretty n + +newtype ForeignName = ForeignName { unForeignName :: ShortByteString } + deriving stock (Eq, Ord, Read, Show) + +instance IsString ForeignName where + fromString = ForeignName . fromString + +instance Pretty ForeignName where + pretty = pretty . show . unForeignName -instance Pretty Name where - pretty (Name n) = pretty n - pretty (ExternalName str) = pretty $ show str - pretty (SubName name n) = pretty name <> "." <> pretty n - pretty UnusedName = "_" +newtype Label = Label { unLabel :: Int } + deriving newtype (Eq, Ord, Read, Show) + +instance Pretty Label where + pretty (Label idx) = "@" <> pretty idx data Type = IntType Int | TupleType [Type] deriving stock (Eq, Read, Show) @@ -108,8 +141,6 @@ data Operand deriving stock (Eq, Read, Show) instance Pretty Operand where - -- pretty (Reference t name) = pretty t <+> "%" <> pretty name - -- pretty (Address t addr) = pretty t <+> "@" <> pretty addr pretty (Reference _ name) = "%" <> pretty name pretty (Address _ addr) = "@" <> pretty addr pretty Empty = "[]" @@ -138,17 +169,12 @@ opType = \case data Instruction -- | Allows setting a = b. = Pure Operand - -- | Calls the symbol 'Name' with the given arguments. - | Call Type Name [Operand] + -- | Calls the function with the given arguments. + | Call Type FunctionName [Operand] -- | Loads the value of a pointer. | Load Operand -- | Stores the second value into the first pointer. | Store Operand Operand - {-| - Runs the instructions in the first body if the value of the operand is - @True@. Otherwise, it runs the instructions in the second body. - -} - | Branch Operand Body Body deriving stock (Eq, Read, Show) instance Pretty Instruction where @@ -157,8 +183,6 @@ instance Pretty Instruction where = foldl' (<+>) ("Call" <+> pretty name) (pretty <$> args) pretty (Load op) = "Load" <+> pretty op pretty (Store op1 op2) = "Store" <+> pretty op1 <+> pretty op2 - pretty (Branch op bt bf) = nest 4 ("If" <+> pretty op >>> pretty bt) - >>> nest 4 ("Else" >>> pretty bf) >>> "End" instrType :: Instruction -> Type instrType = \case @@ -166,7 +190,40 @@ instrType = \case Call t _ _ -> t Load ptr -> opType ptr Store _ _ -> IntType 0 - Branch _ bt _ -> instrType $ bodyTerm bt + +data Terminator + = Jump Label + {-| + Jumps to the first label if the value of the operand is @True@. + Otherwise, it jumps to the second label. + -} + | Branch Operand Label Label + | Return Operand + -- | Calls the function and returns its return value. + | TailCall Name Operand + -- | Indicates that this block is unreachable. + | Unreachable + deriving stock (Eq, Read, Show) + +instance Pretty Terminator where + pretty (Jump lbl) = "Jump" <+> pretty lbl + pretty (Branch op lblt lblf) + = "Branch" <+> pretty op <+> pretty lblt <+> pretty lblf + pretty (Return op) = "Return" <+> pretty op + pretty (TailCall name parg) = "TailCall" <+> pretty name <+> pretty parg + pretty Unreachable = "Unreachable" + +_Return :: Prism' Terminator Operand +_Return = prism Return $ \case + Return op -> Right op + term -> Left term +{-# INLINE _Return #-} + +_TailCall :: Prism' Terminator (Name, Operand) +_TailCall = prism (uncurry TailCall) $ \case + TailCall name parg -> Right (name, parg) + term -> Left term +{-# INLINE _TailCall #-} data Partial a where Partial :: SNat ('Succ n) -> FoldArrow ('Succ n) Operand a -> Partial a @@ -198,32 +255,111 @@ type family FoldArrow n a b where FoldArrow 'Zero _ b = b FoldArrow ('Succ n) a b = a -> FoldArrow n a b -data Named a = Name := a +data Named' a b = a := b deriving stock (Eq, Read, Show, Foldable, Functor, Traversable) -instance Pretty a => Pretty (Named a) where +instance (Pretty a, Pretty b) => Pretty (Named' a b) where pretty (name := a) = pretty name <+> "=" <+> pretty a -data Body = Body - { bodyInstrs :: DList (Named Instruction) - -- | The last instruction in the body. - , bodyTerm :: Instruction +instance Bifunctor Named' where + bimap f g (name := a) = f name := g a + +type Named = Named' Name +type ForeignNamed = Named' ForeignName +type NamedFunction + = Either (Named ImplicitFunction) (Named' FunctionName Function) + +data Block = Block + { blockInstrs :: DList (Named Instruction) + , blockTerm :: Terminator } deriving stock (Eq, Read, Show) -instance Pretty Body where +instance Pretty Block where pretty b = concatWith (>>>) . toList - $ snoc (pretty <$> bodyInstrs b) (pretty $ bodyTerm b) + $ snoc (pretty <$> blockInstrs b) (pretty $ blockTerm b) + +_blockInstrs :: Lens' Block (DList (Named Instruction)) +_blockInstrs = lens blockInstrs $ \b instrs -> b { blockInstrs = instrs } +{-# INLINE _blockInstrs #-} + +_blockTerm :: Lens' Block Terminator +_blockTerm = lens blockTerm $ \b term -> b { blockTerm = term } +{-# INLINE _blockTerm #-} + +newtype IBlock = IBlock { unIBlock :: DList (Named Instruction) } + deriving stock (Eq, Read, Show) + deriving newtype (Monoid, Semigroup) + +instance Pretty IBlock where + pretty (IBlock instrs) = concatWith (>>>) . toList $ pretty <$> instrs + +_IBlock :: Iso' IBlock (DList (Named Instruction)) +_IBlock = iso unIBlock IBlock +{-# INLINE _IBlock #-} + +data BlockList = BlockList + { entryBlock :: Block + , namedBlocks :: NamedBlockList + } deriving stock (Eq, Read, Show) + +instance Pretty BlockList where + pretty bs = concatWith (>>>) + $ indent 4 (pretty $ entryBlock bs) : prettyNamedBlocks (namedBlocks bs) + +_entryBlock :: Lens' BlockList Block +_entryBlock = lens entryBlock $ \bs b -> bs { entryBlock = b } +{-# INLINE _entryBlock #-} + +_namedBlocks :: Lens' BlockList NamedBlockList +_namedBlocks = lens namedBlocks $ \bs nbs -> bs { namedBlocks = nbs } +{-# INLINE _namedBlocks #-} + +newtype NamedBlockList = NamedBlockList { unNamedBlockList :: IM.IntMap Block } + deriving stock (Eq, Read, Show) + deriving newtype (Monoid, Semigroup) + +instance Pretty NamedBlockList where + pretty nbs = concatWith (>>>) $ prettyNamedBlocks nbs + +prettyNamedBlocks :: NamedBlockList -> [Doc ann] +prettyNamedBlocks nbs = prettyLabel <$> IM.assocs (unNamedBlockList nbs) + where + prettyLabel (lbl, b) = nest 4 $ pretty lbl <> ":" <> line <> pretty b data Function = Function { functionArgs :: [Named Type] - , functionBody :: Body + , functionRet :: Type + , functionBlocks :: BlockList } deriving stock (Eq, Read, Show) instance Pretty Function where - pretty f = nest 4 ("Function" <+> tupled (pretty <$> functionArgs f) - >>> pretty (functionBody f)) + pretty f = "Function" <+> pretty (functionRet f) + <+> tupled (pretty <$> functionArgs f) + >>> pretty (functionBlocks f) >>> "End" +_functionArgs :: Lens' Function [Named Type] +_functionArgs = lens functionArgs $ \f args -> f { functionArgs = args } +{-# INLINE _functionArgs #-} + +_functionRet :: Lens' Function Type +_functionRet = lens functionRet $ \f t -> f { functionRet = t } +{-# INLINE _functionRet #-} + +data ImplicitFunction = ImplicitFunction + { ifunctionArgs :: [Named Type] + , ifunctionBlocks :: BlockList + } + deriving stock (Eq, Read, Show) + +instance Pretty ImplicitFunction where + pretty f = "Implicit Function" <+> tupled (pretty <$> ifunctionArgs f) + >>> pretty (ifunctionBlocks f) >>> "End" + +_ifunctionBlocks :: Lens' ImplicitFunction BlockList +_ifunctionBlocks = lens ifunctionBlocks $ \f bs -> f { ifunctionBlocks = bs } +{-# INLINE _ifunctionBlocks #-} + data External = External { externalArgs :: [Type] , externalRet :: Type @@ -233,15 +369,14 @@ instance Pretty External where pretty (External args ret) = pretty ret <+> tupled (pretty <$> args) data Program = Program - { programImports :: [Named External] - , programFunctions :: [Named Function] } + { programImports :: [ForeignNamed External] + , programFunctions :: [NamedFunction] + } deriving stock (Eq, Read, Show) instance Pretty Program where - pretty (Program exts funcs) = concatWith f - [ concatWith f (pretty <$> exts) - , concatWith f (pretty <$> funcs) - ] + pretty (Program exts funcs) + = concatWith f $ (pretty <$> exts) <> (either pretty pretty <$> funcs) where f a b = a <> line <> line <> b @@ -250,12 +385,6 @@ addOperand op (Partial (SSucc n) f) = case n of SZero -> Right $ f op SSucc _ -> Left $ Partial n $ f op -concatBody :: Name -> Body -> Body -> Body -concatBody name b1 b2 = Body - { bodyInstrs = snoc (bodyInstrs b1) (name := bodyTerm b1) <> bodyInstrs b2 - , bodyTerm = bodyTerm b2 - } - opRefs :: Traversal' Operand (Type, Name) opRefs f op = case op of Reference t name -> uncurry Reference <$> f (t, name) @@ -268,22 +397,7 @@ opRefs f op = case op of -> Select <$> opRefs f opc <*> opRefs f opt <*> opRefs f opf Tuple ops -> Tuple <$> traverse (opRefs f) ops GetElement idx opt -> GetElement idx <$> opRefs f opt - -renameOp :: M.Map Name Operand -> Operand -> Operand -renameOp re op = case op of - Reference _ name -> fromMaybe op $ re M.!? name - Address _ _ -> op - Empty -> op - Constant _ -> op - IsolateBit size idx op' -> IsolateBit size idx $ renameOp re op' - InsertBit size oph opt -> InsertBit size (renameOp re oph) (renameOp re opt) - Select opc opt opf - -> Select (renameOp re opc) (renameOp re opt) (renameOp re opf) - Tuple ops -> Tuple $ renameOp re <$> ops - GetElement idx opt -> GetElement idx $ renameOp re opt - -renameInstr :: M.Map Name Operand -> Instruction -> Instruction -renameInstr re = instrOps %~ renameOp re +{-# INLINABLE opRefs #-} instrOps :: Traversal' Instruction Operand instrOps f instr = case instr of @@ -291,41 +405,59 @@ instrOps f instr = case instr of Call t name args -> Call t name <$> traverse f args Load ptr -> Load <$> f ptr Store ptr op -> Store <$> f ptr <*> f op - Branch opc bt bf -> Branch <$> f opc <*> bodyOps f bt <*> bodyOps f bf - -instrBodies :: Traversal' Instruction Body -instrBodies f instr = case instr of - Pure _ -> pure instr - Call {} -> pure instr - Load _ -> pure instr - Store _ _ -> pure instr - Branch opc bt bf -> Branch opc <$> f bt <*> f bf -renameBody :: M.Map Name Operand -> Body -> Body -renameBody re = bodyOps %~ renameOp re - -bodyOps :: Traversal' Body Operand -bodyOps f (Body instrs term) = Body <$> go instrs <*> instrOps f term +termOps :: Traversal' Terminator Operand +termOps f = \case + Jump lbl -> pure $ Jump lbl + Branch opc lblt lblf -> (\opc' -> Branch opc' lblt lblf) <$> f opc + Return op -> Return <$> f op + TailCall name parg -> TailCall name <$> f parg + Unreachable -> pure Unreachable +{-# INLINABLE termOps #-} + +blockOps :: Traversal' Block Operand +blockOps f (Block instrs term) = Block <$> go instrs <*> termOps f term where go = traverse . traverse $ instrOps f +{-# INLINABLE blockOps #-} -bodyBoundNames :: Traversal' Body Name -bodyBoundNames f (Body instrs term) = Body <$> go instrs <*> visit term +blockBoundNames :: Traversal' Block Name +blockBoundNames f (Block instrs term) = Block <$> go instrs <*> pure term where - go = traverse $ \(name := instr) -> (:=) <$> f name <*> visit instr - visit = instrBodies . bodyBoundNames $ f + go = traverse $ \(name := instr) -> (:=) <$> f name <*> pure instr +{-# INLINABLE blockBoundNames #-} -bodyFreeRefs :: Traversal' Body (Type, Name) -bodyFreeRefs f b@(Body instrs term) = Body <$> go instrs <*> instrNames g term +blockFreeRefs :: Traversal' Block (Type, Name) +blockFreeRefs f b@(Block instrs term) = Block <$> go instrs <*> termNames g term where go = traverse . traverse $ instrNames g g ref - | anyOf bodyBoundNames (== snd ref) b = pure ref + | anyOf blockBoundNames (== snd ref) b = pure ref | otherwise = f ref instrNames :: Traversal' Instruction (Type, Name) instrNames = instrOps . opRefs + termNames :: Traversal' Terminator (Type, Name) + termNames = termOps . opRefs +{-# INLINABLE blockFreeRefs #-} + +blockListBlocks :: Traversal' BlockList Block +blockListBlocks f (BlockList eb (NamedBlockList nbs)) + = BlockList <$> f eb <*> (NamedBlockList <$> traverse f nbs) +{-# INLINABLE blockListBlocks #-} + +blockListBoundNames :: Traversal' BlockList Name +blockListBoundNames = blockListBlocks . blockBoundNames +{-# INLINABLE blockListBoundNames #-} + +blockListFreeRefs :: Traversal' BlockList (Type, Name) +blockListFreeRefs f bs = (blockListBlocks . blockFreeRefs . filtered g) f bs + where + g :: (Type, Name) -> Bool + g (_, name) = noneOf blockListBoundNames (name ==) bs +{-# INLINABLE blockListFreeRefs #-} + (>>>) :: Doc ann -> Doc ann -> Doc ann a >>> b = a <> flatAlt hardline "; " <> b infixr 6 >>> diff --git a/src/Language/Elemental/Backend/LLVM.hs b/src/Language/Elemental/Backend/LLVM.hs index 210b3e5..971352d 100644 --- a/src/Language/Elemental/Backend/LLVM.hs +++ b/src/Language/Elemental/Backend/LLVM.hs @@ -1,15 +1,20 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ImportQualifiedPost #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Language.Elemental.Backend.LLVM ( compileProgram , compileExternal , compileFunction - , compileBody + , compileBlockList + , compileBlock , compileInstruction + , compileTerminator , compileOperand , toLlvmName , toLlvmType @@ -20,9 +25,15 @@ module Language.Elemental.Backend.LLVM , Scope ) where +import Control.Algebra ((:+:)) import Control.Carrier.Reader (Reader, asks, local, runReader) -import Data.Foldable (foldrM) +import Control.Carrier.State.Church (State, evalState, get, modify) +import Control.Lens hiding (Empty, op) +import Data.Foldable (fold, foldl', foldrM) import Data.Functor (void) +import Data.Graph (SCC(AcyclicSCC, CyclicSCC), stronglyConnComp) +import Data.IntMap qualified as IM +import Data.List (elemIndex, nub) import Data.Map qualified as M import Data.Maybe (fromMaybe) import Data.String (fromString) @@ -33,6 +44,7 @@ import LLVM.AST.Linkage qualified as LLVM.Linkage import LLVM.AST.Type qualified as LLVM.Type import Math.NumberTheory.Logarithms (naturalLog2) import Numeric.Natural (Natural) +import Prettyprinter (pretty, (<+>)) import Control.Carrier.IRBuilder import Control.Carrier.ModuleBuilder @@ -40,54 +52,153 @@ import Language.Elemental.Backend type LlvmOp = (LLVM.Type, Maybe LLVM.Operand) -type Scope = Reader (M.Map Name LLVM.Operand) +type Scope + = Reader (M.Map FunctionName LLVM.Operand) + :+: Reader (M.Map Name Function) + :+: Reader (IM.IntMap LLVM.Name) -- | Assumes that functions are defined before the functions that use them. compileProgram :: Program -> [LLVM.Definition] compileProgram (Program exts funcs) = run $ runModuleBuilder (const . pure) emptyModuleBuilder - $ runReader @(M.Map Name LLVM.Operand) M.empty - $ foldr compileExternal (foldr compileFunction (pure ()) funcs) exts + $ runReader initScope $ runReader pfuncs $ runReader (IM.empty @LLVM.Name) + $ foldr compileExternal (foldr compileFunction (pure ()) efuncs) exts + where + extMap = M.fromList $ (\(name := ext) -> (name, ext)) <$> exts + + initScope :: M.Map FunctionName LLVM.Operand + efuncs :: [ForeignNamed (LLVM.Linkage.Linkage, Function)] + pfuncs :: M.Map Name Function + (initScope, efuncs, pfuncs) = run $ evalState @Int 0 + $ fmap fold $ traverse nameFunction $ M.assocs + $ foldl' (flip toExplicit) M.empty $ stronglyConnComp $ toConn <$> funcs + + nameFunction + :: forall sig m. Has (State Int) sig m + => (FunctionName, Function) + -> m (M.Map FunctionName LLVM.Operand + , [ForeignNamed (LLVM.Linkage.Linkage, Function)] + , M.Map Name Function) + nameFunction (funcName@(PrivateName name), func) = go + where + go :: m (M.Map FunctionName LLVM.Operand + , [ForeignNamed (LLVM.Linkage.Linkage, Function)] + , M.Map Name Function) + go = do + idx <- get @Int <* modify @Int succ + let namef = ForeignName . ("__elem_" <>) . fromString $ show idx + opf = LLVM.ConstantOperand $ LLVM.Constant.GlobalReference t + $ toLlvmName namef + t = LLVM.Type.ptr $ LLVM.FunctionType tret targs False + targs = toLlvmType . (\(_ := t') -> t') <$> functionArgs func + tret = toLlvmType $ functionRet func + lf = (LLVM.Linkage.Private, func) + pf = M.singleton name func + if M.member namef extMap + then go + else pure (M.singleton funcName opf, [namef := lf], pf) + nameFunction (ExternalName name, func) + = pure (mempty, [name := (LLVM.Linkage.External, func)], mempty) + + toExplicit + :: SCC NamedFunction + -> M.Map FunctionName Function -> M.Map FunctionName Function + toExplicit scc fs = fs <> case scc of + AcyclicSCC nf -> either go sing nf + CyclicSCC nfs -> foldMap (either go sing) nfs + where + iargs = scc ^.. traverse . implicitArgs + trets = scc ^.. traverse . retTypes + + go :: Named ImplicitFunction -> M.Map FunctionName Function + go (name := ImplicitFunction args' bs) + = M.singleton (PrivateName name) (Function (nub args) ret bs) + where + args = args' <> iargs + ret = case nub trets of + [] -> IntType 0 + [t] -> t + ts -> TupleType ts + + sing (name := func) = M.singleton name func + + implicitArgs :: Monoid a => Getting a NamedFunction (Named Type) + implicitArgs = _Left . traverse . _ifunctionBlocks . (blockListBlocks + . _blockTerm . _TailCall . _1 . to ((fs M.!?) . PrivateName) + . traverse . _functionArgs . dropping 1 traverse + <> blockListFreeRefs . to (uncurry $ flip (:=))) + + retTypes :: Monoid a => Getting a NamedFunction Type + retTypes = _Left . traverse . _ifunctionBlocks . (blRets <> blTails) + + blRets :: Fold BlockList Type + blRets = blockListBlocks . _blockTerm . _Return . to opType + + blTails :: Fold BlockList Type + blTails = blockListBlocks . _blockTerm . _TailCall . _1 + . to ((fs M.!?) . PrivateName) . traverse . _functionRet + + toConn :: NamedFunction -> (NamedFunction, FunctionName, [FunctionName]) + toConn nf = (nf, name, nf ^.. refs) + where + name = case nf of + Left (name' := _) -> PrivateName name' + Right (name' := _) -> name' + + refs :: Fold NamedFunction FunctionName + refs = _Left . traverse . _ifunctionBlocks . blockListBlocks + . _blockTerm . _TailCall . _1 . to PrivateName compileExternal :: (Has ModuleBuilder sig m, Has Scope sig m) - => Named External -> m r -> m r + => ForeignNamed External -> m r -> m r compileExternal (name := External targs tret) cont = do - let (_, lname) = toLlvmName name + let lname = toLlvmName name lopf <- extern lname (toLlvmType <$> targs) (toLlvmType tret) - local (M.insert name lopf) cont + local (M.insert (ExternalName name) lopf) cont compileFunction :: forall sig m r. (Has ModuleBuilder sig m, Has Scope sig m) - => Named Function -> m r -> m r -compileFunction (name := Function args b) cont = do - let tret = toLlvmType $ instrType $ bodyTerm b - (linkage, lname) = toLlvmName name - lopf <- function lname (toLlvmType . namedValue <$> args) tret linkage + => ForeignNamed (LLVM.Linkage.Linkage, Function) -> m r -> m r +compileFunction (name := (linkage, Function args ret bs)) cont = do + let tret = toLlvmType ret + lname = toLlvmName name + _ <- function lname (toLlvmType . namedValue <$> args) tret linkage $ \lops -> do - foldr bindOp (compileBody b >>= mkRet) $ zip args lops + foldr bindOp (compileBlockList ret bs) $ zip args lops void block - local (M.insert name lopf) cont + cont where namedValue :: Named a -> a namedValue (_ := a) = a bindOp :: (Named Type, LLVM.Operand) -> IRBuilderC m r' -> IRBuilderC m r' - bindOp (name' := _, lop) = local (M.insert name' lop) + bindOp (name' := _, lop) = local (M.insert (PrivateName name') lop) - mkRet :: LlvmOp -> IRBuilderC m () - mkRet = emitTerm . ($ []) . LLVM.Ret . snd +compileBlockList + :: (Has IRBuilder sig m, Has Scope sig m) => Type -> BlockList -> m () +compileBlockList tret (BlockList be (NamedBlockList bs)) = do + labels <- traverse (const fresh) bs + local (labels <>) $ compileBlock tret be $ foldr go (pure ()) (IM.assocs bs) + where + go (idx, b) cont = do + llbl <- asks $ fromMaybe abort . (IM.!? idx) + emitBlockStart llbl + compileBlock tret b cont + where + abort = error . show $ "compileBlockList: label not in scope:" + <+> pretty (Label idx) -compileBody - :: forall sig m. (Has IRBuilder sig m, Has Scope sig m) => Body -> m LlvmOp -compileBody (Body instrs term) = foldr go (compileInstruction term) instrs +compileBlock + :: forall sig m. (Has IRBuilder sig m, Has Scope sig m) + => Type -> Block -> m () -> m () +compileBlock tret (Block instrs term) cont + = foldr go (compileTerminator tret term *> cont) instrs where go :: Named Instruction -> m r -> m r - go (name := instr) cont = do + go (name := instr) cont' = do lop <- compileInstruction instr - case name of - UnusedName -> cont - _ -> local (M.insert name $ orUndef lop) cont + local (M.insert (PrivateName name) $ orUndef lop) cont' compileInstruction :: (Has IRBuilder sig m, Has Scope sig m) => Instruction -> m LlvmOp @@ -113,34 +224,62 @@ compileInstruction = \case lop = fromMaybe (undef lt) mlop emitInstrVoid $ LLVM.Store True lptr lop Nothing 1 [] pure (LLVM.VoidType, Nothing) - Branch opc bt bf -> do - lopc <- orUndef <$> compileOperand opc - lbt <- fresh - lbf <- fresh - lbr <- fresh - emitTerm $ LLVM.CondBr lopc lbt lbf [] - emitBlockStart lbt - (ltt, mlopt) <- compileBody bt - lbt' <- currentBlock - emitTerm $ LLVM.Br lbr [] - emitBlockStart lbf - (ltf, mlopf) <- compileBody bf - lbf' <- currentBlock - emitTerm $ LLVM.Br lbr [] - emitBlockStart lbr - case (mlopt, mlopf) of - (Nothing, Nothing) -> pure (ltt, Nothing) - _ -> do - let lopt = orUndef (ltt, mlopt) - lopf = orUndef (ltf, mlopf) - ((,) ltt . Just <$>) $ emitInstr ltt - $ LLVM.Phi ltt [(lopt, lbt'), (lopf, lbf')] [] where mkParam a = (a, []) +compileTerminator + :: (Has IRBuilder sig m, Has Scope sig m) => Type -> Terminator -> m () +compileTerminator tret = \case + Jump lbl -> do + llbl <- getLabel lbl + emitTerm $ LLVM.Br llbl [] + Branch opc lblt lblf -> do + lopc <- orUndef <$> compileOperand opc + llblt <- getLabel lblt + llblf <- getLabel lblf + emitTerm $ LLVM.CondBr lopc llblt llblf [] + Return op + | opType op == tret -> do + (_, lop) <- compileOperand op + emitTerm $ LLVM.Ret lop [] + | otherwise -> do + let opt = Tuple $ ix idx .~ op $ (`Reference` Name 0) <$> ts + idx = fromMaybe abortRetType $ elemIndex (opType op) ts + ts = case tret of + TupleType ts' -> ts' + _ -> abortRetType + (_, lop) <- compileOperand opt + emitTerm $ LLVM.Ret lop [] + TailCall name parg -> do + let abort = error . show + $ "compileTerminator: function not in scope:" <+> pretty name + mkArg (name' := t) = Reference t name' + Function args ret _ <- asks $ fromMaybe abort . (M.!? name) + let args' = zipWith (fromMaybe . mkArg) args + $ Just parg : repeat Nothing + (_, lop) <- compileInstruction $ Call ret (PrivateName name) args' + if ret == tret then emitTerm $ LLVM.Ret lop [] else do + let idx = fromMaybe abortRetType $ elemIndex tret ts + ts = case ret of + TupleType ts' -> ts' + _ -> abortRetType + op = fromMaybe abortRetType lop + tmp = Name $ -2 + (_, lop') <- local (M.insert (PrivateName tmp) op) + $ compileOperand $ GetElement idx $ Reference ret tmp + emitTerm $ LLVM.Ret lop' [] + Unreachable -> emitTerm $ LLVM.Unreachable [] + where + abortRetType = error . show + $ "compileTerminator: incompatible return type" <+> pretty tret + getLabel lbl = asks $ fromMaybe abort . (IM.!? unLabel lbl) + where + abort = error . show + $ "compileTerminator: label not in scope:" <+> pretty lbl + compileOperand :: (Has IRBuilder sig m, Has Scope sig m) => Operand -> m LlvmOp compileOperand = skipVoid $ \case - Reference t name -> asks $ (,) (toLlvmType t) . (M.!? name) + Reference t name -> asks $ (,) (toLlvmType t) . (M.!? PrivateName name) Address t addr -> pure $ (,) (toLlvmType t) $ Just $ LLVM.ConstantOperand $ LLVM.Constant.IntToPtr (toLlvmNat addr) $ LLVM.Type.ptr $ toLlvmType t Empty -> pure (LLVM.VoidType, Nothing) @@ -201,18 +340,8 @@ undef = LLVM.ConstantOperand . LLVM.Constant.Undef orUndef :: LlvmOp -> LLVM.Operand orUndef (lt, mlop) = fromMaybe (undef lt) mlop -toLlvmName :: Name -> (LLVM.Linkage.Linkage, LLVM.Name) -toLlvmName name = case name of - Name {} -> (LLVM.Linkage.Private, LLVM.Name $ go name) - ExternalName {} -> (LLVM.Linkage.External, LLVM.Name $ go name) - SubName {} -> (LLVM.Linkage.Private, LLVM.Name $ go name) - UnusedName {} -> (LLVM.Linkage.Private, LLVM.Name $ go name) - where - go = \case - Name idx -> fromString $ show idx - ExternalName name' -> name' - SubName name' idx -> go name' <> fromString ('.' : show idx) - UnusedName -> "_" +toLlvmName :: ForeignName -> LLVM.Name +toLlvmName (ForeignName s) = LLVM.Name s toLlvmType :: Type -> LLVM.Type toLlvmType = \case diff --git a/src/Language/Elemental/Emit.hs b/src/Language/Elemental/Emit.hs index 2527cb9..92b84a8 100644 --- a/src/Language/Elemental/Emit.hs +++ b/src/Language/Elemental/Emit.hs @@ -40,14 +40,16 @@ import Language.Elemental.Singleton -- | Emits a program as an interaction net. emitProgram - :: HasRewriter sig m => Program -> m [Backend.Named Backend.External] + :: HasRewriter sig m + => Program -> m [Backend.ForeignNamed Backend.External] emitProgram (Program decls) = toList <$> emitDeclScope SNil SNil decls -- | Emits a list of declarations. emitDeclScope :: (HasRewriter sig m) => SList (SType 'Zero) scope -> SList (Const (Ref -> m ())) scope - -> DeclScope scope rest -> m (DList (Backend.Named Backend.External)) + -> DeclScope scope rest + -> m (DList (Backend.ForeignNamed Backend.External)) emitDeclScope scopeTypes scope = \case DeclNil -> pure mempty DeclCons decl decls -> case declType scopeTypes decl of @@ -55,8 +57,8 @@ emitDeclScope scopeTypes scope = \case exts <- emitDecl scopeTypes scope () decl (exts <>) <$> emitDeclScope scopeTypes scope decls SJust t -> do - rn0 <- newNode $ const $ AppNode () () () - rn1 <- newNode $ const $ LamNode () () () + rn0 <- newNode $ AppNode () () () + rn1 <- newNode $ LamNode () () () linkNodes (Ref rn0 0) (Ref rn1 0) propagate2 (Ref rn0 2) (Ref rn1 2) DeadNode exts <- emitDecl scopeTypes scope (Const $ Ref rn0 1) decl @@ -72,27 +74,35 @@ emitDecl :: (HasRewriter sig m) => SList (SType 'Zero) scope -> SList (Const (Ref -> m ())) scope -> FoldMaybe () (Const Ref) mt -> Decl scope mt - -> m (DList (Backend.Named Backend.External)) + -> m (DList (Backend.ForeignNamed Backend.External)) emitDecl scopeTypes scope rr = \case Binding expr -> mempty <$ emitExpr scope (getConst rr) expr ForeignImport fname t -> do let ltargs = sForeignArgs t ltret = sForeignRet t name = backendForeignName fname + ext = Backend.External (backendArgs ltargs) (backendType ltret) emitExpr scope (getConst rr) $ wrapImport SZero scopeTypes t $ Call name ltargs ltret - pure $ pure $ name - Backend.:= Backend.External (backendArgs ltargs) (backendType ltret) + pure $ pure $ name Backend.:= ext ForeignExport fname expr -> do let t = exprType SZero scopeTypes expr ltargs = sForeignArgs t ltret = sForeignRet t - freshNums <- traverseSList newNodeIndex ltargs - let names = Backend.Name . fromIntegral <$> freshNums - ops = zipWith Backend.Reference (backendArgs ltargs) names - args = zipWith (Backend.:=) names (backendArgs ltargs) - rn1 <- newNode $ const $ RootNode (backendForeignName fname) args () - emitExpr scope (Ref rn1 0) $ applyArgs ltret ltargs ops + names <- traverseSList newName ltargs + let ops = zipWith Backend.Reference (backendArgs ltargs) names + bargs = zipWith (Backend.:=) names (backendArgs ltargs) + bret = backendType ltret + bname = backendForeignName fname + rn1 <- newNode $ ExternalRootNode bname bargs bret () + rn2 <- newNode $ AccumIONode mempty () () + rn3 <- newNode $ Bind0FNode () () + rn4 <- newNode $ AppNode () () () + linkNodes (Ref rn1 0) (Ref rn2 1) + linkNodes (Ref rn2 0) (Ref rn4 2) + linkNodes (Ref rn3 1) (Ref rn4 0) + mkLambda (Ref rn4 1) ReturnNode + emitExpr scope (Ref rn3 0) $ applyArgs ltret ltargs ops $ wrapExport SZero scopeTypes t expr pure mempty ForeignPrimitive pfin @@ -105,17 +115,15 @@ emitDecl scopeTypes scope rr = \case i0 = SBackendType li0 in case pk of SReadPointer -> (mempty <$) $ emitExpr scope (getConst rr) $ BindIO - :@ lt :$ BackendIO (sMarshall t) - (Backend.Body mempty $ Backend.Load baddr) - :@ t :$ Lam lt (PureIO :@ t - :$ marshallIn SZero (lt :^ scopeTypes) t (Var SZero)) + :@ lt :$ BackendIO (sMarshall t) (Backend.Load baddr) + :@ t :$ (lt + :\ marshallIn SZero (lt :^ scopeTypes) t (Var SZero)) SWritePointer -> (mempty <$) $ emitExpr scope (getConst rr) $ Lam t $ BindIO :@ i0 :$ (BackendPIO (sMarshall t) li0 (Backend.Store baddr) :$ marshallOut SZero (t :^ scopeTypes) t (Var SZero)) - :@ SUnitType :$ Lam i0 (PureIO :@ SUnitType - :$ marshallIn SZero (i0 :^ t :^ scopeTypes) SUnitType - (Var SZero)) + :@ SUnitType :$ (i0 :\ marshallIn SZero (i0 :^ t :^ scopeTypes) + SUnitType (Var SZero)) where traverseSList :: Applicative f => f a -> SList sing as -> f [a] traverseSList _ SNil = pure [] @@ -146,47 +154,53 @@ emitExpr emitExpr scope rr = \case Var vidx -> mkBox vidx >>= getConst (scope !!^ vidx) App ef ex -> do - rn1 <- newNode $ const $ AppNode () () () + rn1 <- newNode $ AppNode () () () emitExpr scope (Ref rn1 0) ef emitExpr scope (Ref rn1 1) ex linkNodes rr $ Ref rn1 2 TypeApp ef _ -> emitExpr scope rr ef Lam _ ey -> do - rn1 <- newNode $ const $ LamNode () () () + rn1 <- newNode $ LamNode () () () Ref rn1 1 >=^ scope $ \scope' -> emitExpr scope' (Ref rn1 2) ey linkNodes rr $ Ref rn1 0 TypeLam ex -> emitExpr (coerceScope scope) rr ex Addr addr _ tx -> do - rn1 <- newNode $ const $ OperandNode (Backend.Address + rn1 <- newNode $ OperandNode (Backend.Address (backendType $ sMarshall tx) $ getAddress addr) () linkNodes rr $ Ref rn1 0 BackendOperand _ op -> do - rn1 <- newNode $ const $ OperandNode op () - linkNodes rr $ Ref rn1 0 - BackendIO _ body -> do - rn1 <- newNode $ const $ IONode body () + rn1 <- newNode $ OperandNode op () linkNodes rr $ Ref rn1 0 + BackendIO _ instr -> propagate1 rr $ IOContNode instr BackendPIO _ _ pio -> mkLambda rr $ IOPNode (Backend.Partial (SSucc SZero) pio) - PureIO -> mkLambda rr Pure0Node - BindIO -> mkLambda rr Bind0Node + PureIO -> do + rn1 <- newNode $ LamNode () () () + rn2 <- newNode $ IOPureNode () () + rn3 <- newNode $ LamNode () () () + rn4 <- newNode $ AppNode () () () + rn5 <- newNode $ BoxNode 0 () () + linkNodes (Ref rn1 1) (Ref rn5 0) + linkNodes (Ref rn1 2) (Ref rn2 0) + linkNodes (Ref rn2 1) (Ref rn3 0) + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes (Ref rn3 2) (Ref rn4 2) + linkNodes (Ref rn4 1) (Ref rn5 1) + linkNodes rr $ Ref rn1 0 + BindIO -> mkLambda rr Bind0BNode LoadPointer -> do - rn1 <- newNode $ const $ LamNode () () () + rn1 <- newNode $ LamNode () () () linkNodes (Ref rn1 1) (Ref rn1 2) linkNodes rr $ Ref rn1 0 StorePointer -> do - rn1 <- newNode $ const $ LamNode () () () + rn1 <- newNode $ LamNode () () () linkNodes (Ref rn1 1) (Ref rn1 2) linkNodes rr $ Ref rn1 0 - Call name SNil tret -> do - let body = Backend.Body - { Backend.bodyInstrs = mempty - , Backend.bodyTerm = Backend.Call (backendType tret) name [] - } - propagate1 rr $ IONode body - Call name ltargs@(_ :^ _) tret -> do + Call fname SNil tret -> propagate1 rr $ IOContNode + $ Backend.Call (backendType tret) (Backend.ExternalName fname) [] + Call fname ltargs@(_ :^ _) tret -> do let callp = Backend.Partial len $ withVarargs len - $ Backend.Call (backendType tret) name + $ Backend.Call (backendType tret) (Backend.ExternalName fname) len = sLength ltargs mkLambda rr $ IOPNode callp IsolateBit bidx ssize -> do @@ -198,7 +212,7 @@ emitExpr scope rr = \case let opp = Backend.Partial (SSucc $ SSucc SZero) $ Backend.InsertBit size size = fromIntegral $ toNatural ssize mkLambda rr $ OperandPNode opp - TestBit -> mkLambda rr $ Branch0Node 0 + TestBit -> mkLambda rr Branch0Node where coerceScope :: SList (Const a) as -> SList (Const a) (IncrementAll 'Zero as) coerceScope SNil = SNil @@ -212,7 +226,7 @@ emitExpr scope rr = \case mkBox SZero = pure rr mkBox (SSucc n) = do r1 <- mkBox n - rn2 <- newNode $ const $ BoxNode 0 () () + rn2 <- newNode $ BoxNode 0 () () linkNodes r1 $ Ref rn2 1 pure $ Ref rn2 0 @@ -242,7 +256,7 @@ emitExpr scope rr = \case case mr3 of Nothing -> put (r2, Just r1) Just r3 -> do - rn4 <- newNode $ const $ DupNode 0 mempty () () () + rn4 <- newNode $ DupNode 0 () () () linkNodes r2 $ Ref rn4 0 linkNodes r3 $ Ref rn4 1 put (Ref rn4 2, Just r1) @@ -255,8 +269,8 @@ backendType :: SBackendType t -> Backend.Type backendType (SBackendInt size) = Backend.IntType $ fromIntegral $ toNatural size -- | Converts a foreign name to a name in the backend AST. -backendForeignName :: ForeignName -> Backend.Name -backendForeignName (ForeignName t) = Backend.ExternalName $ toShortByteString t +backendForeignName :: ForeignName -> Backend.ForeignName +backendForeignName (ForeignName t) = Backend.ForeignName $ toShortByteString t -- GHC gives a nonexhaustive pattern warning if this is inlined. :/ -- | Calls a continuation with a proof relating 'AllIsOpType' and 'IsOpType'. diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 270706d..f815760 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -17,9 +17,8 @@ This evaluator makes the following assumptions about the input: - The program is total. - There are no edges between ports whose types don't unify. - - IO is never duplicated, eliminated, or branched without a continuation. - The easiest way of using the evaluator is to use 'compileINet'. + The easiest way of using the evaluator is to use 'reduce'. Should you choose to manually generate an interaction net instead of using existing functions, be careful not to violate these assumptions, else your @@ -43,8 +42,6 @@ module Language.Elemental.InteractionNet , INetF(..) , Ref(..) , Level(..) - , Preaction(..) - , Renames , HasRewriter , compileINet , reduce @@ -52,11 +49,13 @@ module Language.Elemental.InteractionNet , propagate2 , mkLambda , newNode - , newNodeIndex + , newName + , newLabel , linkNodes -- * Debugging , TraceRewrite(..) , traceRewrite + , deleteBoxes ) where import Control.Algebra (Has, send) @@ -64,22 +63,18 @@ import Control.Carrier.Writer.Church (Writer, execWriter, tell) import Control.Effect.State (State, get, gets, modify) import Control.Lens.At (At(at), Index, Ixed(ix), IxValue) import Control.Lens.Cons (_head) -import Control.Lens.Fold (IndexedFold, filtered, folded, imapMOf_, (^..), (^?)) +import Control.Lens.Fold (IndexedFold, filtered, folded, imapMOf_, (^?)) import Control.Lens.Getter (to) import Control.Lens.Indexed (Indexed(Indexed), indexing) import Control.Lens.Iso (Iso', iso) import Control.Lens.Setter ((.~), (%~), (?~)) import Control.Lens.Traversal (traversed) import Control.Lens.Wrapped (_Wrapped) -import Data.Bifunctor (second) -import Data.DList (DList, toList) +import Data.DList (snoc) import Data.Foldable (find) import Data.IntMap.Strict qualified as IM import Data.IntSet qualified as IS -import Data.List (nub) -import Data.Map.Lazy qualified as M import Data.Maybe (fromMaybe) -import Data.Tuple (swap) import Prettyprinter import Language.Elemental.Backend qualified as B @@ -109,6 +104,12 @@ _INet :: Iso' INet (IM.IntMap (INetF Ref)) _INet = iso unINet INet {-# INLINE _INet #-} +{-| + A set of interacting nodes in an interaction net. + + This data structure must be kept in sync with its 'INet', else weird things + will happen. +-} newtype INetPairs = INetPairs { unINetPairs :: IS.IntSet } deriving newtype (Semigroup, Monoid) @@ -116,91 +117,175 @@ _INetPairs :: Iso' INetPairs IS.IntSet _INetPairs = iso unINetPairs INetPairs {-# INLINE _INetPairs #-} +-- | A reference to a port in an interaction net. data Ref = Ref { refNode :: Int + -- ^ The index of the port's node. , refPort :: Int + -- ^ The index of the port within the node's port list. } deriving stock (Eq, Ord, Show) instance Pretty Ref where pretty r0 = pretty (refNode r0) <> ":" <> pretty (refPort r0) +{-| + The "level" of a node. + + 'DupNode'-related interactions use this to determine whether two nodes + annihilate (same level) or commute (different levels). +-} +newtype Level = Level { unLevel :: Int } + deriving newtype (Enum, Eq, Ord, Num, Pretty) + +{-| + A node in the interaction net. + + The documentation for each constructor indicates the intended type for the + node's ports. + + +----------+--------------------------------------------------------+ + | Type | Description | + +==========+========================================================+ + | @a -> b@ | A function taking an @a@ as input and returning a @b@. | + +----------+--------------------------------------------------------+ + | @i{n}@ | An operand of the specified type (e.g. @i8@). | + +----------+--------------------------------------------------------+ + | @IO a@ | An IO action returning a value of type @a@. | + +----------+--------------------------------------------------------+ + | @B@ | A list of blocks. | + +----------+--------------------------------------------------------+ + | @CB@ | A fully-reduced (i.e. completed) list of blocks. | + +----------+--------------------------------------------------------+ + | @NB@ | A list of named blocks. | + +----------+--------------------------------------------------------+ + | @T@ | A tunnel for pairing 'DupNode' when sharing blocks. | + +----------+--------------------------------------------------------+ +-} data INetF a -- | (a -> b, a, b) = AppNode a a a -- | (a -> b, a, b) | LamNode a a a -- | (a, a, a) - | DupNode Level Renames a a a - -- | Void (i.e. any type) + | DupNode Level a a a + -- | a | DeadNode a -- | (a, a) and the non-principal node is in a new box. | BoxNode Level a a -- FFI - -- | IO i{n} - | RootNode B.Name [B.Named B.Type] a + -- | CB + | ExternalRootNode B.ForeignName [B.Named B.Type] B.Type a + -- | CB + | PrivateRootNode B.Name B.Name a + -- | (CB, B) + | AccumIONode B.IBlock a a + -- | (NB, CB) + | AccumNBNode B.BlockList a a -- | i{n} | OperandNode B.Operand a - -- | (i{n}, {... ->} i{n}) + -- | (i{m}, {... ->} i{n}) | OperandPNode (B.Partial B.Operand) a a - -- | IO i{n} - | IONode B.Body a - -- | (i{n}, {... ->} i{n}) + -- | B + | IONode B.BlockList a + -- | (i{m}, {... ->} IO i{n}) | IOPNode (B.Partial B.Instruction) a a - -- | (IO a, IO a) - | IOContNode Preaction a a - -- | (a, IO a) - | Pure0Node a a + -- | (IO a, (a -> B) -> B) + | IOPureNode a a + -- | IO a + | IOContNode B.Instruction a + -- | (i{n}, B) + | ReturnNode a a -- | (IO a, (a -> IO b) -> IO b) - | Bind0Node a a - -- | (IO b, IO b) - | Bind1Node Preaction a a - -- | (i1, a -> a -> a) - | Branch0Node Level a a - -- | (a, a -> a) - | Branch1Node Level B.Operand a a - -- | (IO a, a, IO a) - | Branch2BNode Level B.Operand Preaction a a a - -- | (IO (a -> b), a -> b, IO (a -> b)) - | Branch2PNode Level B.Operand a a a - -- | (IO (a -> b), a -> b, a -> b) - | Branch3PNode Level B.Operand a a a + | Bind0BNode a a + -- | (IO a, (a -> B) -> B) + | Bind0FNode a a + -- | (B, B) + | Bind1FNode (B.Named B.Instruction) a a + -- | (i1, IO (a -> a -> a)) + | Branch0Node a a + -- | (i1, B, B, B) + | Branch0FNode a a a a + -- | (B, B, B) + | Branch1Node B.Operand a a a + -- | (CB, NB) + | LabelNode B.Label a a + -- | NB + | NamedBlockNode B.NamedBlockList a + -- | (NB, NB, NB) + | Merge0Node a a a + -- | (NB, NB) + | Merge1Node B.NamedBlockList a a + -- | (B, T, T, B) or (T, T, T, T) + | TBuildNode Level B.Name B.Name a a a a + -- | (B, T) + | TEntryNode B.Name B.Operand a a + -- | (T, T, T) + | TSplitNode a a a + -- | T + | TCloseNode a + -- | (T, B, B) + | TLeaveNode a a a + -- | (T, T, T, i1) + | TMatchNode Level a a a a deriving stock (Foldable, Functor, Traversable) instance Pretty a => Pretty (INetF a) where pretty (AppNode r0 r1 r2) = "App" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (LamNode r0 r1 r2) = "Lam" <+> pretty r0 <+> pretty r1 <+> pretty r2 - pretty (DupNode lvl _ r0 r1 r2) + pretty (DupNode lvl r0 r1 r2) = "Dup" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (DeadNode r0) = "Dead" <+> pretty r0 pretty (BoxNode lvl r0 r1) = "Box" <+> pretty lvl <+> pretty r0 <+> pretty r1 - pretty (RootNode name args r0) - = "Root" <+> pretty r0 <+> pretty name <+> tupled (pretty <$> args) + pretty (ExternalRootNode fname args ret r0) + = "ExternalRoot" <+> pretty r0 + <+> pretty fname <+> tupled (pretty <$> args) <+> pretty ret + pretty (PrivateRootNode fname namep r0) + = "PrivateRoot" <+> pretty r0 <+> pretty fname <+> pretty namep + pretty (AccumIONode ib r0 r1) + = "AccumIO" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty ib) + pretty (AccumNBNode bs r0 r1) + = "AccumNB" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty bs) + <> nest 4 (line <> pretty bs) pretty (OperandNode op r0) = "Operand" <+> pretty r0 <+> pretty op pretty (OperandPNode opp r0 r1) = "OperandP" <+> pretty r0 <+> pretty r1 <+> pretty opp - pretty (IONode b r0) = "IO" <+> pretty r0 <> nest 4 (line <> pretty b) + pretty (IONode bs r0) = "IO" <+> pretty r0 <> nest 4 (line <> pretty bs) pretty (IOPNode iop r0 r1) = "IOP" <+> pretty r0 <+> pretty r1 <+> pretty iop - pretty (IOContNode nbs r0 r1) - = "IOCont" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty nbs) - pretty (Pure0Node r0 r1) = "Pure0" <+> pretty r0 <+> pretty r1 - pretty (Bind0Node r0 r1) = "Bind0" <+> pretty r0 <+> pretty r1 - pretty (Bind1Node nbs r0 r1) - = "Bind1" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty nbs) - pretty (Branch0Node lvl r0 r1) - = "Branch0" <+> pretty lvl <+> pretty r0 <+> pretty r1 - pretty (Branch1Node lvl op r0 r1) - = "Branch1" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty op - pretty (Branch2BNode lvl opc nbt r0 r1 r2) - = "Branch2B" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 - <+> pretty opc <> nest 4 (line <> pretty nbt) - pretty (Branch2PNode lvl opc r0 r1 r2) - = "Branch2P" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 - <+> pretty opc - pretty (Branch3PNode lvl opc r0 r1 r2) - = "Branch3P" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 - <+> pretty opc + pretty (IOPureNode r0 r1) = "IOPure" <+> pretty r0 <+> pretty r1 + pretty (IOContNode instr r0) + = "IOCont" <+> pretty r0 <> nest 4 (line <> pretty instr) + pretty (ReturnNode r0 r1) = "Return" <+> pretty r0 <+> pretty r1 + pretty (Bind0BNode r0 r1) = "Bind0B" <+> pretty r0 <+> pretty r1 + pretty (Bind0FNode r0 r1) = "Bind0F" <+> pretty r0 <+> pretty r1 + pretty (Bind1FNode nbs r0 r1) + = "Bind1F" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty nbs) + pretty (Branch0Node r0 r1) = "Branch0" <+> pretty r0 <+> pretty r1 + pretty (Branch0FNode r0 r1 r2 r3) + = "Branch0F" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 + pretty (Branch1Node opc r0 r1 r2) + = "Branch1" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty opc + pretty (LabelNode lbl r0 r1) + = "Label" <+> pretty r0 <+> pretty r1 <+> pretty lbl + pretty (NamedBlockNode nbs r0) + = "NamedBlock" <+> pretty r0 <> nest 4 (line <> pretty nbs) + pretty (Merge0Node r0 r1 r2) + = "Merge0" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (Merge1Node nbs r0 r1) + = "Merge1" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty nbs) + pretty (TBuildNode lvl name namep r0 r1 r2 r3) = "TBuild" + <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 + <+> pretty name <+> pretty namep + pretty (TEntryNode name opp r0 r1) + = "TEntry" <+> pretty r0 <+> pretty r1 <+> pretty name <+> pretty opp + pretty (TSplitNode r0 r1 r2) + = "TSplit" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (TCloseNode r0) = "TClose" <+> pretty r0 + pretty (TLeaveNode r0 r1 r2) + = "TLeave" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (TMatchNode lvl r0 r1 r2 r3) = "TMatch" + <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 instance Ixed (INetF a) where ix idx f = indexing traverse $ Indexed go @@ -213,43 +298,16 @@ instance Ixed (INetF a) where type instance Index (INetF a) = Int type instance IxValue (INetF a) = a -newtype Level = Level { unLevel :: Int } - deriving newtype (Enum, Eq, Ord, Num, Pretty) - --- | Instructions that should run before a continuation. -data Preaction - = SimplePreaction B.Name B.Body - | BranchPreaction B.Operand Preaction Preaction - | ConcatPreaction Preaction Preaction - | EmptyPreaction - -instance Semigroup Preaction where - (<>) = ConcatPreaction - -instance Monoid Preaction where - mempty = EmptyPreaction - -instance Pretty Preaction where - pretty (SimplePreaction name b) = pretty name <+> "=" <+> pretty b - pretty (BranchPreaction op nb1 nb2) = "If" <+> pretty op <+> "Then" - <> nest 4 (line <> pretty nb1) <> line <> "Else" - <> nest 4 (line <> pretty nb2) <> line <> "End" - pretty (ConcatPreaction nb1 nb2) = pretty nb1 <> line <> pretty nb2 - pretty EmptyPreaction = "_ = []" - -type Renames = M.Map B.Name (B.Operand, B.Operand) - +-- | Compiles an interaction net and a list of externals into a backend program. compileINet :: (HasRewriter sig m, Has TraceRewrite sig m) - => [B.Named B.External] -> m B.Program -compileINet exts = B.Program exts . toList <$> execWriter reduce + => [B.ForeignNamed B.External] -> m B.Program +compileINet exts = B.Program exts <$> reduce {-# INLINABLE compileINet #-} -reduce - :: (HasRewriter sig m, Has TraceRewrite sig m - , Has (Writer (DList (B.Named B.Function))) sig m) - => m () -reduce = try *> lintFinal +-- | Reduces the interaction net into a list of functions. +reduce :: (HasRewriter sig m, Has TraceRewrite sig m) => m [B.NamedFunction] +reduce = execWriter $ try *> lintFinal where go r0 = do net <- get @@ -263,7 +321,7 @@ reduce = try *> lintFinal try try :: (HasRewriter sig m, Has TraceRewrite sig m - , Has (Writer (DList (B.Named B.Function))) sig m) + , Has (Writer [B.NamedFunction]) sig m) => m () try = do net <- get @@ -272,7 +330,9 @@ reduce = try *> lintFinal Just rn0 -> go $ Ref rn0 0 isRoot :: INetF Ref -> Bool - isRoot RootNode {} = True + isRoot ExternalRootNode {} = True + isRoot PrivateRootNode {} = True + isRoot TEntryNode {} = True isRoot _ = False derefNode :: INet -> Int -> INetF Ref @@ -304,38 +364,38 @@ reduce = try *> lintFinal net <- get case find isRoot $ unINet net of Nothing -> pure () - Just _ -> error . show $ "lint: failed to reduce root" - <> line <> pretty net + Just _ -> do + deleteBoxes + net' <- get @INet + error . show $ "lint: failed to reduce root" + <> line <> pretty net' {-# INLINABLE reduce #-} reduceNode - :: (HasRewriter sig m, Has (Writer (DList (B.Named B.Function))) sig m) + :: (HasRewriter sig m, Has (Writer [B.NamedFunction]) sig m) => INetF Ref -> INetF Ref -> m () --- reduceNode (AppNode _ r0 r1) (AppNode _ r2 r3) --- = linkNodes r0 r2 *> linkNodes r1 r3 reduceNode (AppNode _ r0 r1) (LamNode _ r2 r3) = do - rn4 <- newNode $ const $ BoxNode 0 () () - rn5 <- newNode $ const $ BoxNode 0 () () + rn4 <- newNode $ BoxNode 0 () () + rn5 <- newNode $ BoxNode 0 () () linkNodes r0 $ Ref rn4 0 linkNodes r1 $ Ref rn5 0 linkNodes r2 $ Ref rn4 1 linkNodes r3 $ Ref rn5 1 reduceNode n0@LamNode {} n1@AppNode {} = reduceNode n1 n0 -reduceNode (AppNode _ r0 r1) (DupNode lvl re _ r2 r3) - = commute2 AppNode (DupNode lvl re) r0 r1 r2 r3 +reduceNode (AppNode _ r0 r1) (DupNode lvl _ r2 r3) + = commute2 AppNode (DupNode lvl) r0 r1 r2 r3 reduceNode n0@DupNode {} n1@AppNode {} = reduceNode n1 n0 -reduceNode (LamNode _ r0 r1) (DupNode lvl re _ r2 r3) - = commute2 LamNode (DupNode (succ lvl) re) r0 r1 r2 r3 +reduceNode (LamNode _ r0 r1) (DupNode lvl _ r2 r3) + = commute2 LamNode (DupNode $ succ lvl) r0 r1 r2 r3 reduceNode n0@DupNode {} n1@LamNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl1 re1 _ r0 r1) (DupNode lvl2 re2 _ r2 r3) +reduceNode (DupNode lvl1 _ r0 r1) (DupNode lvl2 _ r2 r3) | lvl1 == lvl2 = linkNodes r0 r2 *> linkNodes r1 r3 - | lvl1 == 10 && lvl2 == 11 || lvl1 == 11 && lvl2 == 10 = linkNodes r0 r2 *> linkNodes r1 r3 - | otherwise = commute2 (DupNode lvl1 re1) (DupNode lvl2 re2) r0 r1 r2 r3 + | otherwise = commute2 (DupNode lvl1) (DupNode lvl2) r0 r1 r2 r3 reduceNode (AppNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@AppNode {} = reduceNode n1 n0 reduceNode (LamNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@LamNode {} = reduceNode n1 n0 -reduceNode (DupNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode (DupNode _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DeadNode _) (DeadNode _) = pure () -- Book-keeping @@ -345,8 +405,8 @@ reduceNode n0@BoxNode {} n1@AppNode {} = reduceNode n1 n0 reduceNode (LamNode _ r0 r1) (BoxNode lvl _ r2) = commute1 LamNode (BoxNode $ succ lvl) r0 r1 r2 reduceNode n0@BoxNode {} n1@LamNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (BoxNode lvl1 _ r2) = commute1 - (DupNode (if lvl0 < lvl1 then lvl0 else succ lvl0) re) +reduceNode (DupNode lvl0 _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (DupNode $ if lvl0 < lvl1 then lvl0 else succ lvl0) (BoxNode lvl1) r0 r1 r2 reduceNode n0@BoxNode {} n1@DupNode {} = reduceNode n1 n0 @@ -359,9 +419,45 @@ reduceNode (BoxNode lvl0 _ r0) (BoxNode lvl1 _ r1) (BoxNode $ if lvl1 < lvl0 then lvl1 else succ lvl1) r0 r1 -- FFI -reduceNode (RootNode name args _) (IONode b _) - = tell $ pure @DList $ name B.:= B.Function args b -reduceNode n0@IONode {} n1@RootNode {} = reduceNode n1 n0 +reduceNode (ExternalRootNode fname args ret _) (IONode b _) + = tell @[B.NamedFunction] $ pure $ Right + $ B.ExternalName fname B.:= B.Function args ret b +reduceNode n0@IONode {} n1@ExternalRootNode {} = reduceNode n1 n0 +reduceNode (PrivateRootNode name namep _) (IONode bs _) + = tell @[B.NamedFunction] $ pure $ Left + $ name B.:= B.ImplicitFunction [namep B.:= B.IntType 1] bs +reduceNode n0@IONode {} n1@PrivateRootNode {} = reduceNode n1 n0 +reduceNode (AccumIONode ib _ r0) (IONode bs _) = propagate1 r0 + $ IONode $ B._entryBlock . B._blockInstrs %~ (B.unIBlock ib <>) $ bs +reduceNode n0@IONode {} n1@AccumIONode {} = reduceNode n1 n0 +reduceNode (AccumIONode ib _ r0) (Bind1FNode instr _ r1) = do + let ib' = B._IBlock %~ (`snoc` instr) $ ib + rn2 <- newNode $ AccumIONode ib' () () + linkNodes r0 $ Ref rn2 1 + linkNodes r1 $ Ref rn2 0 +reduceNode n0@Bind1FNode {} n1@AccumIONode {} = reduceNode n1 n0 +reduceNode (AccumIONode ib _ r0) (Branch1Node opc _ r1 r2) = do + lblt <- newLabel + lblf <- newLabel + let b = B.Block (B.unIBlock ib) $ B.Branch opc lblt lblf + rn3 <- newNode $ AccumNBNode (B.BlockList b mempty) () () + rn4 <- newNode $ Merge0Node () () () + rn5 <- newNode $ LabelNode lblt () () + rn6 <- newNode $ LabelNode lblf () () + rn7 <- newNode $ AccumIONode mempty () () + rn8 <- newNode $ AccumIONode mempty () () + linkNodes (Ref rn3 0) (Ref rn4 2) + linkNodes (Ref rn4 0) (Ref rn5 1) + linkNodes (Ref rn4 1) (Ref rn6 1) + linkNodes (Ref rn5 0) (Ref rn7 1) + linkNodes (Ref rn6 0) (Ref rn8 1) + linkNodes r0 $ Ref rn3 1 + linkNodes r1 $ Ref rn7 0 + linkNodes r2 $ Ref rn8 0 +reduceNode n0@Branch1Node {} n1@AccumIONode {} = reduceNode n1 n0 +reduceNode (AccumNBNode bs _ r0) (NamedBlockNode nbs _) + = propagate1 r0 $ IONode $ B._namedBlocks %~ (<>) nbs $ bs +reduceNode n0@NamedBlockNode {} n1@AccumNBNode {} = reduceNode n1 n0 reduceNode (OperandPNode opp _ r0) (OperandNode op _) = case B.addOperand op opp of Left opp' -> mkLambda r0 $ OperandPNode opp' @@ -370,234 +466,283 @@ reduceNode n0@OperandNode {} n1@OperandPNode {} = reduceNode n1 n0 reduceNode (IOPNode iop _ r0) (OperandNode op _) = case B.addOperand op iop of Left iop' -> mkLambda r0 $ IOPNode iop' - Right instr -> propagate1 r0 $ IONode $ B.Body mempty instr + Right instr -> propagate1 r0 $ IOContNode instr reduceNode n0@OperandNode {} n1@IOPNode {} = reduceNode n1 n0 -reduceNode (Pure0Node _ r0) (LamNode _ r1 r2) = do - rn3 <- newNode $ const $ IOContNode mempty () () - rn4 <- newNode $ const $ LamNode () () () - linkNodes (Ref rn3 1) (Ref rn4 0) - linkNodes r0 $ Ref rn3 0 - linkNodes r1 $ Ref rn4 1 - linkNodes r2 $ Ref rn4 2 -reduceNode n0@LamNode {} n1@Pure0Node {} = reduceNode n1 n0 -reduceNode (Pure0Node _ r0) (Branch3PNode lvl opc _ r1 r2) = do - rn3 <- newNode $ const $ IOContNode mempty () () - rn4 <- newNode $ const $ Branch3PNode lvl opc () () () - linkNodes (Ref rn3 1) (Ref rn4 0) - linkNodes r0 $ Ref rn3 0 - linkNodes r1 $ Ref rn4 1 - linkNodes r2 $ Ref rn4 2 -reduceNode n0@Branch3PNode {} n1@Pure0Node {} = reduceNode n1 n0 -reduceNode (Pure0Node _ r0) (OperandNode op _) - = propagate1 r0 $ IONode $ B.Body mempty $ B.Pure op -reduceNode n0@OperandNode {} n1@Pure0Node {} = reduceNode n1 n0 -reduceNode (Pure0Node _ r0) (IONode b _) = do - rn3 <- newNode $ const $ IOContNode mempty () () - rn4 <- newNode $ const $ IONode b () - linkNodes (Ref rn3 1) (Ref rn4 0) - linkNodes r0 $ Ref rn3 0 -reduceNode n0@IONode {} n1@Pure0Node {} = reduceNode n1 n0 -reduceNode (Pure0Node _ r0) (IOContNode nbs _ r1) = do - rn3 <- newNode $ const $ IOContNode mempty () () - rn4 <- newNode $ const $ IOContNode nbs () () - linkNodes (Ref rn3 1) (Ref rn4 0) - linkNodes r0 $ Ref rn3 0 - linkNodes r1 $ Ref rn4 1 -reduceNode n0@IOContNode {} n1@Pure0Node {} = reduceNode n1 n0 -reduceNode (Bind0Node _ r0) (IOContNode nbs _ r1) = do - rn2 <- newNode $ const $ Bind1Node nbs () () - rn3 <- newNode $ const $ AppNode () () () - rn4 <- newNode $ const $ LamNode () () () - linkNodes (Ref rn2 0) (Ref rn3 2) - linkNodes (Ref rn2 1) (Ref rn4 2) - linkNodes (Ref rn3 0) (Ref rn4 1) - linkNodes r0 $ Ref rn4 0 - linkNodes r1 $ Ref rn3 1 -reduceNode n0@IOContNode {} n1@Bind0Node {} = reduceNode n1 n0 -reduceNode (Bind0Node _ r0) (IONode b _) = do - rn1 <- newNode $ \rn1 -> Bind1Node (SimplePreaction (mkName rn1) b) () () - let t = B.instrType $ B.bodyTerm b - rn2 <- newNode $ const $ OperandNode (mkRef t rn1) () - rn3 <- newNode $ const $ AppNode () () () - rn4 <- newNode $ const $ LamNode () () () - linkNodes (Ref rn1 0) (Ref rn3 2) - linkNodes (Ref rn1 1) (Ref rn4 2) - linkNodes (Ref rn2 0) (Ref rn3 1) - linkNodes (Ref rn3 0) (Ref rn4 1) - linkNodes r0 $ Ref rn4 0 -reduceNode n0@IONode {} n1@Bind0Node {} = reduceNode n1 n0 -reduceNode (Bind1Node nbs _ r0) (IONode b2 _) - = propagate1 r0 $ IONode $ applyCont nbs b2 -reduceNode n0@IONode {} n1@Bind1Node {} = reduceNode n1 n0 -reduceNode (Bind1Node nbs1 _ r0) (IOContNode nbs2 _ r1) = do - rn2 <- newNode $ const $ IOContNode (nbs1 <> nbs2) () () +reduceNode (ReturnNode _ r0) (OperandNode op _) = propagate1 r0 + $ IONode $ B.BlockList (B.Block mempty $ B.Return op) mempty +reduceNode n0@OperandNode {} n1@ReturnNode {} = reduceNode n1 n0 +reduceNode (Bind0BNode _ r0) (IOPureNode _ r1) = reassocPure r0 r1 +reduceNode n0@IOPureNode {} n1@Bind0BNode {} = reduceNode n1 n0 +reduceNode (Bind0BNode _ r0) (IOContNode instr _) = reassocCont instr r0 +reduceNode n0@IOContNode {} n1@Bind0BNode {} = reduceNode n1 n0 +reduceNode (Bind0FNode _ r0) (IOPureNode _ r1) = linkNodes r0 r1 +reduceNode n0@IOPureNode {} n1@Bind0FNode {} = reduceNode n1 n0 +reduceNode (Bind0FNode _ r0) (IOContNode instr _) = do + name <- newName + let op = B.Reference (B.instrType instr) name + rn2 <- newNode $ LamNode () () () + rn3 <- newNode $ Bind1FNode (name B.:= instr) () () + rn4 <- newNode $ AppNode () () () + rn5 <- newNode $ OperandNode op () + linkNodes (Ref rn2 1) (Ref rn4 0) + linkNodes (Ref rn2 2) (Ref rn3 0) + linkNodes (Ref rn3 1) (Ref rn4 2) + linkNodes (Ref rn4 1) (Ref rn5 0) linkNodes r0 $ Ref rn2 0 - linkNodes r1 $ Ref rn2 1 -reduceNode n0@IOContNode {} n1@Bind1Node {} = reduceNode n1 n0 -reduceNode (Branch0Node lvl _ r0) (OperandNode op _) - = mkLambda r0 $ Branch1Node lvl op +reduceNode n0@IOContNode {} n1@Bind0FNode {} = reduceNode n1 n0 +reduceNode (Branch0Node _ r0) (OperandNode op _) = do + rn1 <- newNode $ LamNode () () () + rn2 <- newNode $ DupNode 0 () () () + rn3 <- newNode $ AppNode () () () + rn4 <- newNode $ AppNode () () () + r5 <- mkChurchBool const + r6 <- mkChurchBool $ const id + rn7 <- newNode $ Branch1Node op () () () + rn9 <- newNode $ IOPureNode () () + linkNodes (Ref rn1 0) (Ref rn9 1) + linkNodes (Ref rn1 1) (Ref rn2 0) + linkNodes (Ref rn1 2) (Ref rn7 0) + linkNodes (Ref rn2 1) (Ref rn3 0) + linkNodes (Ref rn2 2) (Ref rn4 0) + linkNodes (Ref rn3 2) (Ref rn7 1) + linkNodes (Ref rn4 2) (Ref rn7 2) + linkNodes r0 $ Ref rn9 0 + linkNodes r5 $ Ref rn3 1 + linkNodes r6 $ Ref rn4 1 reduceNode n0@OperandNode {} n1@Branch0Node {} = reduceNode n1 n0 -reduceNode (Branch1Node lvl op _ r0) (AppNode _ r1 r2) = do - rn3 <- newNode $ const $ Branch2PNode lvl op () () () - rn4 <- newNode $ const $ LamNode () () () - rn5 <- newNode $ const $ AppNode () () () - linkNodes (Ref rn3 0) (Ref rn4 1) - linkNodes (Ref rn3 1) (Ref rn5 0) - linkNodes (Ref rn3 2) (Ref rn4 2) - linkNodes r0 $ Ref rn4 0 - linkNodes r1 $ Ref rn5 1 - linkNodes r2 $ Ref rn5 2 -reduceNode n0@AppNode {} n1@Branch1Node {} = reduceNode n1 n0 -reduceNode (Branch1Node lvl op _ r0) (LamNode _ r1 r2) = do - rn3 <- newNode $ const $ Branch2PNode lvl op () () () - rn4 <- newNode $ const $ LamNode () () () - rn5 <- newNode $ const $ LamNode () () () - linkNodes (Ref rn3 0) (Ref rn4 1) - linkNodes (Ref rn3 1) (Ref rn5 0) - linkNodes (Ref rn3 2) (Ref rn4 2) - linkNodes r0 $ Ref rn4 0 - linkNodes r1 $ Ref rn5 1 - linkNodes r2 $ Ref rn5 2 -reduceNode n0@LamNode {} n1@Branch1Node {} = reduceNode n1 n0 -reduceNode (Branch1Node lvl0 opc0 _ r0) (Branch3PNode lvl1 opc1 _ r1 r2) = do - rn3 <- newNode $ const $ Branch2PNode lvl0 opc0 () () () - rn4 <- newNode $ const $ LamNode () () () - rn5 <- newNode $ const $ Branch3PNode lvl1 opc1 () () () - linkNodes (Ref rn3 0) (Ref rn4 1) - linkNodes (Ref rn3 1) (Ref rn5 0) - linkNodes (Ref rn3 2) (Ref rn4 2) - linkNodes r0 $ Ref rn4 0 - linkNodes r1 $ Ref rn5 1 - linkNodes r2 $ Ref rn5 2 -reduceNode n0@Branch3PNode {} n1@Branch1Node {} = reduceNode n1 n0 -reduceNode (Branch1Node _ opc _ r0) (OperandNode opt _) = mkLambda r0 - $ OperandPNode $ B.Partial (SSucc SZero) $ mkSelect opc opt -reduceNode n0@OperandNode {} n1@Branch1Node {} = reduceNode n1 n0 -reduceNode (Branch1Node lvl op _ r0) (IOContNode nbs _ r1) = do - rn3 <- newNode $ const $ Branch2BNode lvl op nbs () () () - rn4 <- newNode $ const $ LamNode () () () - linkNodes (Ref rn3 0) (Ref rn4 1) - linkNodes (Ref rn3 2) (Ref rn4 2) - linkNodes r0 $ Ref rn4 0 - linkNodes r1 $ Ref rn3 1 -reduceNode n0@IOContNode {} n1@Branch1Node {} = reduceNode n1 n0 -reduceNode (Branch2BNode lvl op nbs1 _ r0 r1) (IOContNode nbs2 _ r2) = do - let nbs = BranchPreaction op nbs1 nbs2 - rn3 <- newNode $ const $ Branch1Node lvl op () () - rn4 <- newNode $ const $ AppNode () () () - rn5 <- newNode $ const $ IOContNode nbs () () - linkNodes (Ref rn3 1) (Ref rn4 0) - linkNodes (Ref rn4 2) (Ref rn5 1) - linkNodes r0 $ Ref rn3 0 - linkNodes r1 $ Ref rn5 0 - linkNodes r2 $ Ref rn4 1 -reduceNode n0@IOContNode {} n1@Branch2BNode {} = reduceNode n1 n0 -reduceNode (Branch2PNode lvl opc _ r0 r1) (LamNode _ r2 r3) = do - rn4 <- newNode $ const $ Branch3PNode lvl opc () () () - rn5 <- newNode $ const $ LamNode () () () - linkNodes (Ref rn4 2) (Ref rn5 0) - linkNodes r0 $ Ref rn4 1 - linkNodes r1 $ Ref rn4 0 - linkNodes r2 $ Ref rn5 1 - linkNodes r3 $ Ref rn5 2 -reduceNode n0@LamNode {} n1@Branch2PNode {} = reduceNode n1 n0 -reduceNode (Branch2PNode lvl0 opc0 _ r0 r1) (Branch3PNode lvl1 opc1 _ r2 r3) = do - rn4 <- newNode $ const $ Branch3PNode lvl0 opc0 () () () - rn5 <- newNode $ const $ Branch3PNode lvl1 opc1 () () () - linkNodes (Ref rn4 2) (Ref rn5 0) +reduceNode (Branch0FNode _ r0 r1 r2) (OperandNode op _) = do + rn3 <- newNode $ Branch1Node op () () () + linkNodes r0 $ Ref rn3 1 + linkNodes r1 $ Ref rn3 2 + linkNodes r2 $ Ref rn3 0 +reduceNode n0@OperandNode {} n1@Branch0FNode {} = reduceNode n1 n0 +reduceNode (LabelNode lbl _ r0) (IONode bs _) = propagate1 r0 $ NamedBlockNode + $ B.NamedBlockList $ IM.insert (B.unLabel lbl) (B.entryBlock bs) + $ B.unNamedBlockList $ B.namedBlocks bs +reduceNode n0@IONode {} n1@LabelNode {} = reduceNode n1 n0 +reduceNode (Merge0Node _ r0 r1) (NamedBlockNode nbs _) = do + rn2 <- newNode $ Merge1Node nbs () () + linkNodes r0 $ Ref rn2 0 + linkNodes r1 $ Ref rn2 1 +reduceNode n0@NamedBlockNode {} n1@Merge0Node {} = reduceNode n1 n0 +reduceNode (Merge1Node nbs0 _ r0) (NamedBlockNode nbs1 _) + = propagate1 r0 $ NamedBlockNode $ nbs0 <> nbs1 +reduceNode n0@NamedBlockNode {} n1@Merge1Node {} = reduceNode n1 n0 +reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (IONode bs _) = do + propagate2 r0 r1 TCloseNode + propagate1 r2 $ IONode bs +reduceNode n0@IONode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl name namep _ r0 r1 r2) (Bind1FNode instr _ r3) = do + rn4 <- newNode $ TBuildNode lvl name namep () () () () + rn5 <- newNode $ Bind1FNode instr () () + linkNodes (Ref rn4 3) (Ref rn5 1) linkNodes r0 $ Ref rn4 1 - linkNodes r1 $ Ref rn4 0 - linkNodes r2 $ Ref rn5 1 - linkNodes r3 $ Ref rn5 2 -reduceNode n0@Branch3PNode {} n1@Branch2PNode {} = reduceNode n1 n0 -reduceNode (Branch3PNode lvl opc _ r0 r1) (AppNode _ r2 r3) = do - rn4 <- newNode $ const $ AppNode () () () - rn5 <- newNode $ const $ AppNode () () () - rn6 <- newNode $ const $ DupNode 0 mempty () () () - rn7 <- newNode $ const $ Branch1Node lvl opc () () - rn8 <- newNode $ const $ AppNode () () () - linkNodes (Ref rn4 1) (Ref rn6 1) - linkNodes (Ref rn5 1) (Ref rn6 2) - linkNodes (Ref rn4 2) (Ref rn7 0) - linkNodes (Ref rn5 2) (Ref rn8 1) - linkNodes (Ref rn7 1) (Ref rn8 0) - linkNodes r0 $ Ref rn4 0 - linkNodes r1 $ Ref rn5 0 + linkNodes r1 $ Ref rn4 2 + linkNodes r2 $ Ref rn5 0 + linkNodes r3 $ Ref rn4 0 +reduceNode n0@Bind1FNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl name namep _ r0 r1 r2) (Branch1Node opc _ r3 r4) + = commute2a' (TBuildNode lvl name namep) TSplitNode TSplitNode + (Branch1Node opc) r0 r1 r2 r3 r4 +reduceNode n0@Branch1Node {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (AccumIONode ib _ r0) (TEntryNode name opp _ r1) = do + let term = B.TailCall name opp + propagate1 r0 $ IONode $ B.BlockList (B.Block (B.unIBlock ib) term) mempty + propagate1 r1 TCloseNode +reduceNode n0@TEntryNode {} n1@AccumIONode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl name0 namep _ r0 r1 r2) (TEntryNode name1 opp _ r3) + | name0 == name1 = error "reduceNode: found loop at TBuild/TEntry" + | otherwise = do + rn4 <- newNode $ TBuildNode lvl name0 namep () () () () + rn5 <- newNode $ TEntryNode name1 opp () () + linkNodes (Ref rn4 3) (Ref rn5 1) + linkNodes r0 $ Ref rn4 1 + linkNodes r1 $ Ref rn4 2 + linkNodes r2 $ Ref rn5 0 + linkNodes r3 $ Ref rn4 0 +reduceNode n0@TEntryNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl name namep _ r0 r1 r2) (TSplitNode _ r3 r4) + = commute2a (TBuildNode lvl name namep) TSplitNode r0 r1 r2 r3 r4 +reduceNode n0@TSplitNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (TCloseNode _) + = propagate3 r0 r1 r2 TCloseNode +reduceNode n0@TCloseNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TSplitNode _ r0 r1) (TCloseNode _) = propagate2 r0 r1 TCloseNode +reduceNode n0@TCloseNode {} n1@TSplitNode {} = reduceNode n1 n0 +reduceNode (TCloseNode _) (TCloseNode _) = pure () +reduceNode (TBuildNode lvl name namep _ r0 r1 r2) (TLeaveNode _ r3 r4) = do + rn5 <- newNode $ TBuildNode lvl name namep () () () () + rn6 <- newNode $ TLeaveNode () () () + linkNodes (Ref rn5 3) (Ref rn6 1) + linkNodes r0 $ Ref rn5 1 + linkNodes r1 $ Ref rn5 2 linkNodes r2 $ Ref rn6 0 - linkNodes r3 $ Ref rn8 2 -reduceNode n0@AppNode {} n1@Branch3PNode {} = reduceNode n1 n0 + linkNodes r3 $ Ref rn5 0 + linkNodes r4 $ Ref rn6 2 +reduceNode n0@TLeaveNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TLeaveNode _ r0 r1) (TCloseNode _) = linkNodes r0 r1 +reduceNode n0@TCloseNode {} n1@TLeaveNode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl0 name namep _ r0 r1 r2) (TMatchNode lvl1 _ r3 r4 r5) + | lvl0 == lvl1 = do + linkNodes r0 r3 + linkNodes r1 r4 + propagate1 r2 TCloseNode + propagate1 r5 $ OperandNode $ B.Reference (B.IntType 1) namep + | otherwise = do + let opp = B.Partial (SSucc $ SSucc SZero) $ mkSelect + $ B.Reference (B.IntType 1) namep + rn6 <- newNode $ TBuildNode lvl0 name namep () () () () + rn7 <- newNode $ TBuildNode lvl0 name namep () () () () + rn8 <- newNode $ TMatchNode lvl1 () () () () + rn9 <- newNode $ TMatchNode lvl1 () () () () + rn10 <- newNode $ OperandPNode opp () () + rn11 <- newNode $ AppNode () () () + linkNodes (Ref rn6 1) (Ref rn8 1) + linkNodes (Ref rn6 2) (Ref rn9 1) + propagate1 (Ref rn6 3) TCloseNode + linkNodes (Ref rn7 1) (Ref rn8 2) + linkNodes (Ref rn7 2) (Ref rn9 2) + propagate1 (Ref rn7 3) TCloseNode + linkNodes (Ref rn8 3) (Ref rn10 0) + linkNodes (Ref rn9 3) (Ref rn11 1) + linkNodes (Ref rn10 1) (Ref rn11 0) + linkNodes r0 $ Ref rn8 0 + linkNodes r1 $ Ref rn9 0 + propagate1 r2 TCloseNode + linkNodes r3 $ Ref rn6 0 + linkNodes r4 $ Ref rn7 0 + linkNodes r5 $ Ref rn11 2 +reduceNode n0@TMatchNode {} n1@TBuildNode {} = reduceNode n1 n0 -- FFI Duplication -reduceNode (DupNode _ re _ r0 r1) (OperandNode op _) - = copyIO1 r0 r1 OperandNode B.renameOp re op +reduceNode (DupNode _ _ r0 r1) (OperandNode op _) + = propagate2 r0 r1 $ OperandNode op reduceNode n0@OperandNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (OperandPNode opp _ r2) - = copyIO2 lvl r0 r1 r2 OperandPNode (fmap . B.renameOp) re opp +reduceNode (DupNode lvl _ r0 r1) (OperandPNode opp _ r2) + = commute1 (DupNode lvl) (OperandPNode opp) r0 r1 r2 reduceNode n0@OperandPNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (IOPNode iop _ r2) - = copyIO2 lvl r0 r1 r2 IOPNode (fmap . B.renameInstr) re iop +reduceNode (DupNode lvl _ r0 r1) (IONode bs _) = do + rn2 <- newNode $ IONode bs () + dedupIO lvl r0 r1 $ Ref rn2 0 +reduceNode n0@IONode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (IOPNode iop _ r2) + = commute1 (DupNode lvl) (IOPNode iop) r0 r1 r2 reduceNode n0@IOPNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (IOContNode nbs _ r2) - = shareIOCont lvl re nbs r0 r1 r2 +reduceNode (DupNode lvl _ r0 r1) (IOPureNode _ r2) + = commute1 (DupNode lvl) IOPureNode r0 r1 r2 +reduceNode n0@IOPureNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode _ _ r0 r1) (IOContNode instr _) + = propagate2 r0 r1 $ IOContNode instr reduceNode n0@IOContNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (Pure0Node _ r2) - = commute1 (DupNode lvl re) Pure0Node r0 r1 r2 -reduceNode n0@Pure0Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (Bind0Node _ r2) - = commute1 (DupNode lvl re) Bind0Node r0 r1 r2 -reduceNode n0@Bind0Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl re _ r0 r1) (Bind1Node nbs _ r2) - = shareBind1 lvl re nbs r0 r1 r2 -reduceNode n0@Bind1Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch0Node lvl1 _ r2) - = commute1 (DupNode lvl0 re) (Branch0Node lvl1) r0 r1 r2 +reduceNode (DupNode lvl _ r0 r1) (ReturnNode _ r2) + = commute1 (DupNode lvl) ReturnNode r0 r1 r2 +reduceNode n0@ReturnNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (Bind0BNode _ r2) + = commute1 (DupNode lvl) Bind0BNode r0 r1 r2 +reduceNode n0@Bind0BNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (Bind0FNode _ r2) + = commute1 (DupNode lvl) Bind0FNode r0 r1 r2 +reduceNode n0@Bind0FNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (Bind1FNode b _ r2) + = do + rn3 <- newNode $ Bind1FNode b () () + linkNodes r2 $ Ref rn3 1 + dedupIO lvl r0 r1 $ Ref rn3 0 +reduceNode n0@Bind1FNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 _ r0 r1) (Branch0Node _ r2) + = commute1 (DupNode lvl0) Branch0Node r0 r1 r2 reduceNode n0@Branch0Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch1Node lvl1 op _ r2) - = copyIO2 lvl0 r0 r1 r2 (Branch1Node lvl1) B.renameOp re op +reduceNode (DupNode lvl _ r0 r1) (Branch1Node opc _ r2 r3) + = do + rn4 <- newNode $ Branch1Node opc () () () + linkNodes r2 $ Ref rn4 1 + linkNodes r3 $ Ref rn4 2 + dedupIO lvl r0 r1 $ Ref rn4 0 reduceNode n0@Branch1Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch2BNode lvl1 opc nbt _ r2 r3) - = shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 -reduceNode n0@Branch2BNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch2PNode lvl1 op _ r2 r3) - = commute2' (DupNode lvl0 re) (DupNode lvl0 re) - (Branch2PNode lvl1 $ B.renameOp (M.map fst re) op) - (Branch2PNode lvl1 $ B.renameOp (M.map snd re) op) - r0 r1 r2 r3 -reduceNode n0@Branch2PNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 re _ r0 r1) (Branch3PNode lvl1 op _ r2 r3) - = commute2' (DupNode lvl0 re) (DupNode lvl0 re) - (Branch3PNode lvl1 $ B.renameOp (M.map fst re) op) - (Branch3PNode lvl1 $ B.renameOp (M.map snd re) op) - r0 r1 r2 r3 -reduceNode n0@Branch3PNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 _ r0 r1) (TBuildNode lvl1 name namep _ r2 r3 r4) + | lvl0 == lvl1 = do + let opp = B.Reference (B.IntType 1) namep + rn5 <- newNode $ TLeaveNode () () () + rn6 <- newNode $ TLeaveNode () () () + rn7 <- newNode $ Branch1Node opp () () () + linkNodes (Ref rn5 2) (Ref rn7 1) + linkNodes (Ref rn6 2) (Ref rn7 2) + linkNodes r0 $ Ref rn5 1 + linkNodes r1 $ Ref rn6 1 + linkNodes r2 $ Ref rn5 0 + linkNodes r3 $ Ref rn6 0 + linkNodes r4 $ Ref rn7 0 + | otherwise = do + let opp = B.Partial (SSucc $ SSucc SZero) + $ mkSelect $ B.Reference (B.IntType 1) namep + rn2 <- newNode $ Branch0FNode () () () () + rn3 <- newNode $ OperandPNode opp () () + rn4 <- newNode $ AppNode () () () + rn5 <- newNode $ TMatchNode lvl0 () () () () + rn6 <- newNode $ TMatchNode lvl0 () () () () + rn7 <- newNode $ TBuildNode lvl1 name namep () () () () + rn8 <- newNode $ TBuildNode lvl1 name namep () () () () + linkNodes (Ref rn2 0) (Ref rn4 2) + linkNodes (Ref rn2 1) (Ref rn7 3) + linkNodes (Ref rn2 2) (Ref rn8 3) + linkNodes (Ref rn3 0) (Ref rn5 3) + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes (Ref rn4 1) (Ref rn6 3) + linkNodes (Ref rn5 1) (Ref rn7 1) + linkNodes (Ref rn5 2) (Ref rn8 1) + linkNodes (Ref rn6 1) (Ref rn7 2) + linkNodes (Ref rn6 2) (Ref rn8 2) + linkNodes r0 $ Ref rn7 0 + linkNodes r1 $ Ref rn8 0 + linkNodes r2 $ Ref rn5 0 + linkNodes r3 $ Ref rn6 0 + linkNodes r4 $ Ref rn2 3 +reduceNode n0@TBuildNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (TEntryNode name opp _ r2) = do + rn3 <- newNode $ TEntryNode name opp () () + linkNodes r2 $ Ref rn3 1 + dedupIO lvl r0 r1 $ Ref rn3 0 +reduceNode n0@TEntryNode {} n1@DupNode {} = reduceNode n1 n0 -- FFI Dead +reduceNode (AccumIONode ib _ r0) (DeadNode _) = propagate1 r0 + $ IONode $ B.BlockList (B.Block (B.unIBlock ib) B.Unreachable) mempty +reduceNode n0@DeadNode {} n1@AccumIONode {} = reduceNode n1 n0 reduceNode (OperandNode _ _) (DeadNode _) = pure () reduceNode n0@DeadNode {} n1@OperandNode {} = reduceNode n1 n0 reduceNode (OperandPNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@OperandPNode {} = reduceNode n1 n0 +reduceNode (IONode _ _) (DeadNode _) = pure () +reduceNode n0@DeadNode {} n1@IONode {} = reduceNode n1 n0 reduceNode (IOPNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@IOPNode {} = reduceNode n1 n0 -reduceNode (IOContNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode (IOPureNode _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@IOPureNode {} = reduceNode n1 n0 +reduceNode (IOContNode _ _) (DeadNode _) = pure () reduceNode n0@DeadNode {} n1@IOContNode {} = reduceNode n1 n0 -reduceNode (Pure0Node _ r0) (DeadNode _) = propagate1 r0 DeadNode -reduceNode n0@DeadNode {} n1@Pure0Node {} = reduceNode n1 n0 -reduceNode (Bind0Node _ r0) (DeadNode _) = propagate1 r0 DeadNode -reduceNode n0@DeadNode {} n1@Bind0Node {} = reduceNode n1 n0 -reduceNode (Bind1Node _ _ r0) (DeadNode _) = propagate1 r0 DeadNode -reduceNode n0@DeadNode {} n1@Bind1Node {} = reduceNode n1 n0 -reduceNode (Branch0Node _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode (Bind0BNode _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@Bind0BNode {} = reduceNode n1 n0 +reduceNode (Bind0FNode _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@Bind0FNode {} = reduceNode n1 n0 +reduceNode (Bind1FNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@Bind1FNode {} = reduceNode n1 n0 +reduceNode (Branch0Node _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@Branch0Node {} = reduceNode n1 n0 -reduceNode (Branch1Node _ _ _ r0) (DeadNode _) = propagate1 r0 DeadNode -reduceNode n0@DeadNode {} n1@Branch1Node {} = reduceNode n1 n0 -reduceNode (Branch2BNode _ _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode -reduceNode n0@DeadNode {} n1@Branch2BNode {} = reduceNode n1 n0 -reduceNode (Branch2PNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode -reduceNode n0@DeadNode {} n1@Branch2PNode {} = reduceNode n1 n0 -reduceNode (Branch3PNode _ _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode -reduceNode n0@DeadNode {} n1@Branch3PNode {} = reduceNode n1 n0 +reduceNode (LabelNode lbl _ r0) (DeadNode _) + = propagate1 r0 $ NamedBlockNode $ B.NamedBlockList + $ IM.singleton (B.unLabel lbl) $ B.Block mempty B.Unreachable +reduceNode n0@DeadNode {} n1@LabelNode {} = reduceNode n1 n0 +reduceNode (NamedBlockNode _ _) (DeadNode _) = pure () +reduceNode n0@DeadNode {} n1@NamedBlockNode {} = reduceNode n1 n0 +reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (DeadNode _) + = propagate2 r0 r1 TCloseNode *> propagate1 r2 DeadNode +reduceNode n0@DeadNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TEntryNode _ _ _ r0) (DeadNode _) = propagate1 r0 TCloseNode +reduceNode n0@DeadNode {} n1@TEntryNode {} = reduceNode n1 n0 -- FFI Book-keeping -reduceNode (RootNode name args _) (BoxNode _ _ r0) - = propagate1 r0 $ RootNode name args -reduceNode n0@BoxNode {} n1@RootNode {} = reduceNode n1 n0 +reduceNode (AccumIONode ib _ r0) (BoxNode _ _ r1) = do + rn2 <- newNode $ AccumIONode ib () () + linkNodes r0 $ Ref rn2 1 + linkNodes r1 $ Ref rn2 0 +reduceNode n0@BoxNode {} n1@AccumIONode {} = reduceNode n1 n0 reduceNode (OperandNode op _) (BoxNode _ _ r0) = propagate1 r0 $ OperandNode op reduceNode n0@BoxNode {} n1@OperandNode {} = reduceNode n1 n0 @@ -610,41 +755,61 @@ reduceNode n0@BoxNode {} n1@IONode {} = reduceNode n1 n0 reduceNode (IOPNode iop _ r0) (BoxNode lvl _ r1) = commute0 (IOPNode iop) (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@IOPNode {} = reduceNode n1 n0 -reduceNode (IOContNode nbs _ r0) (BoxNode lvl _ r1) - = commute0 (IOContNode nbs) (BoxNode lvl) r0 r1 +reduceNode (IOPureNode _ r0) (BoxNode lvl _ r1) + = commute0 IOPureNode (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@IOPureNode {} = reduceNode n1 n0 +reduceNode (IOContNode instr _) (BoxNode _ _ r0) + = propagate1 r0 $ IOContNode instr reduceNode n0@BoxNode {} n1@IOContNode {} = reduceNode n1 n0 -reduceNode (Pure0Node _ r0) (BoxNode lvl _ r1) - = commute0 Pure0Node (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@Pure0Node {} = reduceNode n1 n0 -reduceNode (Bind0Node _ r0) (BoxNode lvl _ r1) - = commute0 Bind0Node (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@Bind0Node {} = reduceNode n1 n0 -reduceNode (Bind1Node nbs _ r0) (BoxNode lvl _ r1) - = commute0 (Bind1Node nbs) (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@Bind1Node {} = reduceNode n1 n0 -reduceNode (Branch0Node lvl0 _ r0) (BoxNode lvl1 _ r1) = commute0 - (Branch0Node $ if lvl0 < lvl1 then lvl0 else succ lvl0) (BoxNode lvl1) r0 r1 +reduceNode (ReturnNode _ r0) (BoxNode lvl _ r1) + = commute0 ReturnNode (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@ReturnNode {} = reduceNode n1 n0 +reduceNode (Bind0BNode _ r0) (BoxNode lvl _ r1) + = commute0 Bind0BNode (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@Bind0BNode {} = reduceNode n1 n0 +reduceNode (Bind0FNode _ r0) (BoxNode lvl _ r1) + = commute0 Bind0FNode (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@Bind0FNode {} = reduceNode n1 n0 +reduceNode (Bind1FNode nbs _ r0) (BoxNode lvl _ r1) + = commute0 (Bind1FNode nbs) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@Bind1FNode {} = reduceNode n1 n0 +reduceNode (Branch0Node _ r0) (BoxNode lvl _ r1) + = commute0 Branch0Node (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@Branch0Node {} = reduceNode n1 n0 -reduceNode (Branch1Node lvl0 op _ r0) (BoxNode lvl1 _ r1) = commute0 - (Branch1Node (if lvl0 < lvl1 then lvl0 else succ lvl0) op) - (BoxNode lvl1) - r0 r1 +reduceNode (Branch0FNode _ r0 r1 r2) (BoxNode lvl _ r3) + = commute2b Branch0FNode (BoxNode lvl) r0 r1 r2 r3 +reduceNode n0@BoxNode {} n1@Branch0FNode {} = reduceNode n1 n0 +reduceNode (Branch1Node opp _ r0 r1) (BoxNode lvl _ r2) + = commute1 (Branch1Node opp) (BoxNode lvl) r0 r1 r2 reduceNode n0@BoxNode {} n1@Branch1Node {} = reduceNode n1 n0 -reduceNode (Branch2BNode lvl0 opc nbt _ r0 r1) (BoxNode lvl1 _ r2) = commute1 - (Branch2BNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc nbt) - (BoxNode lvl1) - r0 r1 r2 -reduceNode n0@BoxNode {} n1@Branch2BNode {} = reduceNode n1 n0 -reduceNode (Branch2PNode lvl0 opc _ r0 r1) (BoxNode lvl1 _ r2) = commute1 - (Branch2PNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc) - (BoxNode lvl1) - r0 r1 r2 -reduceNode n0@BoxNode {} n1@Branch2PNode {} = reduceNode n1 n0 -reduceNode (Branch3PNode lvl0 opc _ r0 r1) (BoxNode lvl1 _ r2) = commute1 - (Branch3PNode (if lvl0 < lvl1 then lvl0 else succ lvl0) opc) +reduceNode (LabelNode lbl _ r0) (BoxNode _ _ r1) + = do + rn2 <- newNode $ LabelNode lbl () () + linkNodes r0 $ Ref rn2 1 + linkNodes r1 $ Ref rn2 0 +reduceNode n0@BoxNode {} n1@LabelNode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl0 name namep _ r0 r1 r2) (BoxNode lvl1 _ r3) + = commute2b + (TBuildNode (if lvl0 < lvl1 then lvl0 else succ lvl0) name namep) + (BoxNode lvl1) + r0 r1 r2 r3 +reduceNode n0@BoxNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TEntryNode name opp _ r0) (BoxNode lvl _ r1) + = commute0 (TEntryNode name opp) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@TEntryNode {} = reduceNode n1 n0 +reduceNode (TSplitNode _ r0 r1) (BoxNode lvl _ r2) + = commute1 TSplitNode (BoxNode lvl) r0 r1 r2 +reduceNode n0@BoxNode {} n1@TSplitNode {} = reduceNode n1 n0 +reduceNode (TCloseNode _) (BoxNode _ _ r0) = propagate1 r0 TCloseNode +reduceNode n0@BoxNode {} n1@TCloseNode {} = reduceNode n1 n0 +reduceNode (TLeaveNode _ r0 r1) (BoxNode lvl _ r2) + = commute1 TLeaveNode (BoxNode lvl) r0 r1 r2 +reduceNode n0@BoxNode {} n1@TLeaveNode {} = reduceNode n1 n0 +reduceNode (TMatchNode lvl0 _ r0 r1 r2) (BoxNode lvl1 _ r3) = commute2b + (TMatchNode $ if lvl0 < lvl1 then lvl0 else succ lvl0) (BoxNode lvl1) - r0 r1 r2 -reduceNode n0@BoxNode {} n1@Branch3PNode {} = reduceNode n1 n0 + r0 r1 r2 r3 +reduceNode n0@BoxNode {} n1@TMatchNode {} = reduceNode n1 n0 reduceNode n0 n1 = error . show $ "unexpected node pairing" <> line <> pretty n0 <> line <> pretty n1 {-# INLINABLE reduceNode #-} @@ -654,8 +819,8 @@ commute0 => (() -> () -> INetF ()) -> (() -> () -> INetF ()) -> Ref -> Ref -> m () commute0 mk1 mk2 r0 r1 = do - rn3 <- newNode $ const $ mk2 () () - rn4 <- newNode $ const $ mk1 () () + rn3 <- newNode $ mk2 () () + rn4 <- newNode $ mk1 () () linkNodes (Ref rn3 1) (Ref rn4 1) linkNodes r0 $ Ref rn3 0 linkNodes r1 $ Ref rn4 0 @@ -674,9 +839,9 @@ commute1' -> (() -> () -> INetF ()) -> (() -> () -> INetF ()) -> Ref -> Ref -> Ref -> m () commute1' mk1 mk2a mk2b r0 r1 r2 = do - rn3 <- newNode $ const $ mk2a () () - rn4 <- newNode $ const $ mk2b () () - rn5 <- newNode $ const $ mk1 () () () + rn3 <- newNode $ mk2a () () + rn4 <- newNode $ mk2b () () + rn5 <- newNode $ mk1 () () () linkNodes (Ref rn3 1) (Ref rn5 1) linkNodes (Ref rn4 1) (Ref rn5 2) linkNodes r0 $ Ref rn3 0 @@ -700,10 +865,10 @@ commute2' -> (() -> () -> () -> INetF ()) -> Ref -> Ref -> Ref -> Ref -> m () commute2' mk1a mk1b mk2a mk2b r0 r1 r2 r3 = do - rn4 <- newNode $ const $ mk1a () () () - rn5 <- newNode $ const $ mk1b () () () - rn6 <- newNode $ const $ mk2a () () () - rn7 <- newNode $ const $ mk2b () () () + rn4 <- newNode $ mk1a () () () + rn5 <- newNode $ mk1b () () () + rn6 <- newNode $ mk2a () () () + rn7 <- newNode $ mk2b () () () linkNodes (Ref rn4 1) (Ref rn6 1) linkNodes (Ref rn4 2) (Ref rn7 1) linkNodes (Ref rn5 1) (Ref rn6 2) @@ -714,287 +879,189 @@ commute2' mk1a mk1b mk2a mk2b r0 r1 r2 r3 = do linkNodes r3 $ Ref rn5 0 {-# INLINABLE commute2' #-} -propagate1 :: HasRewriter sig m => Ref -> (() -> INetF ()) -> m () -propagate1 r0 mk1 = do - rn1 <- newNode $ const $ mk1 () - linkNodes r0 $ Ref rn1 0 -{-# INLINABLE propagate1 #-} - -propagate2 :: HasRewriter sig m => Ref -> Ref -> (() -> INetF ()) -> m () -propagate2 r0 r1 mk1 = propagate1 r0 mk1 *> propagate1 r1 mk1 -{-# INLINABLE propagate2 #-} - -copyIO1 +commute2a :: HasRewriter sig m - => Ref -> Ref -> (a -> () -> INetF ()) - -> (M.Map B.Name B.Operand -> a -> a) -> Renames -> a - -> m () -copyIO1 r0 r1 mk1 f re ffi = do - propagate1 r0 $ mk1 $ f (M.map fst re) ffi - propagate1 r1 $ mk1 $ f (M.map snd re) ffi -{-# INLINABLE copyIO1 #-} - -copyIO2 - :: HasRewriter sig m - => Level -> Ref -> Ref -> Ref -> (a -> () -> () -> INetF ()) - -> (M.Map B.Name B.Operand -> a -> a) -> Renames -> a - -> m () -copyIO2 lvl r0 r1 r2 mk1 f re ffi = commute1' (DupNode lvl re) - (mk1 $ f (M.map fst re) ffi) - (mk1 $ f (M.map snd re) ffi) r0 r1 r2 -{-# INLINABLE copyIO2 #-} - -copyIO3 - :: HasRewriter sig m - => Level -> Ref -> Ref -> Ref -> Ref -> (a -> () -> () -> () -> INetF ()) - -> (M.Map B.Name B.Operand -> a -> a) -> Renames -> a - -> m () -copyIO3 lvl r0 r1 r2 r3 mk1 f re ffi = commute2' - (DupNode lvl re) (DupNode lvl re) - (mk1 $ f (M.map fst re) ffi) - (mk1 $ f (M.map snd re) ffi) - r0 r1 r2 r3 -{-# INLINABLE copyIO3 #-} + => (() -> () -> () -> () -> INetF ()) + -> (() -> () -> () -> INetF ()) + -> Ref -> Ref -> Ref -> Ref -> Ref -> m () +commute2a mk1 mk2 = commute2a' mk1 mk2 mk2 mk2 +{-# INLINABLE commute2a #-} -shareIOCont +commute2a' :: HasRewriter sig m - => Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () -shareIOCont = sharePreaction (<>) (pure pure) (pure pure) IOContNode -{-# INLINABLE shareIOCont #-} + => (() -> () -> () -> () -> INetF ()) + -> (() -> () -> () -> INetF ()) + -> (() -> () -> () -> INetF ()) + -> (() -> () -> () -> INetF ()) + -> Ref -> Ref -> Ref -> Ref -> Ref -> m () +commute2a' mk1 mk2a mk2b mk2c r0 r1 r2 r3 r4 = do + rn5 <- newNode $ mk1 () () () () + rn6 <- newNode $ mk1 () () () () + rn7 <- newNode $ mk2a () () () + rn8 <- newNode $ mk2b () () () + rn9 <- newNode $ mk2c () () () + linkNodes (Ref rn5 1) (Ref rn7 1) + linkNodes (Ref rn5 2) (Ref rn8 1) + linkNodes (Ref rn5 3) (Ref rn9 1) + linkNodes (Ref rn6 1) (Ref rn7 2) + linkNodes (Ref rn6 2) (Ref rn8 2) + linkNodes (Ref rn6 3) (Ref rn9 2) + linkNodes r0 $ Ref rn7 0 + linkNodes r1 $ Ref rn8 0 + linkNodes r2 $ Ref rn9 0 + linkNodes r3 $ Ref rn5 0 + linkNodes r4 $ Ref rn6 0 +{-# INLINABLE commute2a' #-} -shareBind1 +commute2b :: HasRewriter sig m - => Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () -shareBind1 lvl = sharePreaction (const id) (wrap fst) (wrap snd) Bind1Node lvl - where - wrap sel re r0 = do - rn1 <- newNode $ const $ DupNode lvl re () () () - rn2 <- newNode $ const $ DeadNode () - linkNodes (Ref rn1 $ sel (2, 1)) (Ref rn2 0) - linkNodes r0 $ Ref rn1 $ sel (1, 2) - pure $ Ref rn1 0 -{-# INLINABLE shareBind1 #-} - -shareBranch2B - :: HasRewriter sig m - => Level -> Level -> Renames -> B.Operand -> Preaction + => (() -> () -> () -> () -> INetF ()) + -> (() -> () -> INetF ()) -> Ref -> Ref -> Ref -> Ref -> m () -shareBranch2B lvl0 lvl1 re opc nbt r0 r1 r2 r3 = case sharePreaction' nbt of - Nothing -> copyIO3 lvl0 r0 r1 r2 r3 mk renamePreaction re nbt - Just (name, sb) | null (B.bodyInstrs sb) -> do - let mkPreaction rn = SimplePreaction (mkName rn) sb - rn4 <- newNode $ \rn4 -> mk (mkPreaction rn4) () () () - rn5 <- newNode $ \rn5 -> mk (mkPreaction rn5) () () () - let re' = M.singleton name (mkRef t rn4, mkRef t rn5) - t = B.instrType $ B.bodyTerm sb - rn6 <- newNode $ const $ DupNode lvl0 re () () () - rn7 <- newNode $ const $ DupNode lvl0 re () () () - r8 <- w1 re' $ Ref rn4 0 - r9 <- w2 re' $ Ref rn5 0 - linkNodes (Ref rn4 1) (Ref rn6 1) - linkNodes (Ref rn5 1) (Ref rn6 2) - linkNodes (Ref rn4 2) (Ref rn7 1) - linkNodes (Ref rn5 2) (Ref rn7 2) - linkNodes r0 r8 - linkNodes r1 r9 - linkNodes r2 $ Ref rn6 0 - linkNodes r3 $ Ref rn7 0 - Just (name, sb) -> do - let names = preactionNames nbt - extraArgs = nub $ sb ^.. B.bodyFreeRefs - args = M.assocs re - args' = uncurry (B.:=) - <$> (swap <$> extraArgs) - <> (second (B.opType . fst) <$> args) - rn4 <- newNode $ \rn4 -> RootNode (mkName rn4) args' () - let mkPreact sel rn = mkCall sel rn - mkCall sel rn = SimplePreaction (mkName rn) $ B.Body mempty - $ B.Call ltt (mkName rn4) - $ (<>) (uncurry B.Reference <$> extraArgs) - $ sel . snd <$> args - sb' = B.concatBody name sb $ B.Body mempty $ B.Pure sop - (sop, gop, ltt) = case names of - [] -> (B.Empty, const $ const B.Empty, B.IntType 0) - [name'] -> (shareRef name', const id, snd name') - _ -> (B.Tuple $ shareRef <$> names, mkGetElement - , B.TupleType $ snd <$> names) - rn5 <- newNode $ const $ IONode sb' () - rn6 <- newNode $ \rn6 -> mk (mkPreact fst rn6) () () () - rn7 <- newNode $ \rn7 -> mk (mkPreact snd rn7) () () () - let re' = M.fromList $ zipWith (dupNames gop ltt rn5 rn6) [0..] names - rn8 <- newNode $ const $ DupNode lvl0 re () () () - rn9 <- newNode $ const $ DupNode lvl0 re () () () - r10 <- w1 re' (Ref rn6 0) - r11 <- w2 re' (Ref rn7 0) - linkNodes (Ref rn4 0) (Ref rn5 0) - linkNodes (Ref rn6 1) (Ref rn8 1) - linkNodes (Ref rn7 1) (Ref rn8 2) - linkNodes (Ref rn6 2) (Ref rn9 1) - linkNodes (Ref rn7 2) (Ref rn9 2) - linkNodes r0 r10 - linkNodes r1 r11 - linkNodes r2 $ Ref rn8 0 - linkNodes r3 $ Ref rn9 0 - where - mk = Branch2BNode lvl1 opc - w1 = wrap fst - w2 = wrap snd - - wrap sel re' r4 = do - rn5 <- newNode $ const $ DupNode lvl0 re' () () () - rn6 <- newNode $ const $ DeadNode () - linkNodes (Ref rn5 $ sel (2, 1)) (Ref rn6 0) - linkNodes r4 $ Ref rn5 $ sel (1, 2) - pure $ Ref rn5 0 +commute2b mk1 mk2 r0 r1 r2 r3 = do + rn4 <- newNode $ mk1 () () () () + rn5 <- newNode $ mk2 () () + rn6 <- newNode $ mk2 () () + rn7 <- newNode $ mk2 () () + linkNodes (Ref rn4 1) (Ref rn5 1) + linkNodes (Ref rn4 2) (Ref rn6 1) + linkNodes (Ref rn4 3) (Ref rn7 1) + linkNodes r0 $ Ref rn5 0 + linkNodes r1 $ Ref rn6 0 + linkNodes r2 $ Ref rn7 0 + linkNodes r3 $ Ref rn4 0 +{-# INLINABLE commute2b #-} - dupNames gop ltt rn3 rn4 idx (name, _) - = (name, (gop idx $ mkRef ltt rn3, gop idx $ mkRef ltt rn4)) - - shareRef :: (B.Name, B.Type) -> B.Operand - shareRef (name, t) = B.Reference t name -{-# INLINABLE shareBranch2B #-} - -sharePreaction - :: HasRewriter sig m - => (Renames -> Renames -> Renames) - -> (Renames -> Ref -> m Ref) -> (Renames -> Ref -> m Ref) - -> (Preaction -> () -> () -> INetF ()) - -> Level -> Renames -> Preaction -> Ref -> Ref -> Ref -> m () -sharePreaction append w1 w2 mk lvl re nbs r0 r1 r2 = case sharePreaction' nbs of - Nothing -> copyIO2 lvl r0 r1 r2 mk renamePreaction re nbs - Just (name, sb) | null (B.bodyInstrs sb) -> do - let mkPreaction rn = SimplePreaction (mkName rn) sb - rn3 <- newNode $ \rn3 -> mk (mkPreaction rn3) () () - rn4 <- newNode $ \rn4 -> mk (mkPreaction rn4) () () - let re' = M.singleton name (mkRef t rn3, mkRef t rn4) - t = B.instrType $ B.bodyTerm sb - rn5 <- newNode $ const $ DupNode lvl (append re' re) () () () - r6 <- w1 re' $ Ref rn3 0 - r7 <- w2 re' $ Ref rn4 0 - linkNodes (Ref rn3 1) (Ref rn5 1) - linkNodes (Ref rn4 1) (Ref rn5 2) - linkNodes r0 r6 - linkNodes r1 r7 - linkNodes r2 $ Ref rn5 0 - Just (name, sb) -> do - let names = preactionNames nbs - extraArgs = nub $ sb ^.. B.bodyFreeRefs - args = M.assocs re - args' = uncurry (B.:=) - <$> (swap <$> extraArgs) - <> (second (B.opType . fst) <$> args) - rn3 <- newNode $ \rn3 -> RootNode (mkName rn3) args' () - let mkPreact sel rn = mkCall sel rn - mkCall sel rn = SimplePreaction (mkName rn) $ B.Body mempty - $ B.Call ltt (mkName rn3) - $ (<>) (uncurry B.Reference <$> extraArgs) - $ sel . snd <$> args - sb' = B.concatBody name sb $ B.Body mempty $ B.Pure sop - (sop, gop, ltt) = case names of - [] -> (B.Empty, const $ const B.Empty, B.IntType 0) - [name'] -> (shareRef name', const id, snd name') - _ -> (B.Tuple $ shareRef <$> names, mkGetElement - , B.TupleType $ snd <$> names) - rn4 <- newNode $ const $ IONode sb' () - rn5 <- newNode $ \rn5 -> mk (mkPreact fst rn5) () () - rn6 <- newNode $ \rn6 -> mk (mkPreact snd rn6) () () - let re' = M.fromList $ zipWith (dupNames gop ltt rn5 rn6) [0..] names - rn7 <- newNode $ const $ DupNode lvl (append re' re) () () () - r8 <- w1 re' (Ref rn5 0) - r9 <- w2 re' (Ref rn6 0) - linkNodes (Ref rn3 0) (Ref rn4 0) - linkNodes (Ref rn5 1) (Ref rn7 1) - linkNodes (Ref rn6 1) (Ref rn7 2) - linkNodes r0 r8 - linkNodes r1 r9 - linkNodes r2 $ Ref rn7 0 - where - dupNames gop ltt rn3 rn4 idx (name, _) - = (name, (gop idx $ mkRef ltt rn3, gop idx $ mkRef ltt rn4)) +propagate1 :: HasRewriter sig m => Ref -> (() -> INetF ()) -> m () +propagate1 r0 mk1 = do + rn1 <- newNode $ mk1 () + linkNodes r0 $ Ref rn1 0 +{-# INLINABLE propagate1 #-} - shareRef :: (B.Name, B.Type) -> B.Operand - shareRef (name, t) = B.Reference t name -{-# INLINABLE sharePreaction #-} +propagate2 :: HasRewriter sig m => Ref -> Ref -> (() -> INetF ()) -> m () +propagate2 r0 r1 mk1 = propagate1 r0 mk1 *> propagate1 r1 mk1 +{-# INLINABLE propagate2 #-} -sharePreaction' :: Preaction -> Maybe (B.Name, B.Body) -sharePreaction' (SimplePreaction name b) = pure (name, b) -sharePreaction' (BranchPreaction opc nb1 nb2) = pure (B.UnusedName - , B.Body mempty $ B.Branch opc (applyCont nb1 eb) (applyCont nb2 eb)) - where - eb = B.Body mempty $ B.Pure B.Empty -sharePreaction' (ConcatPreaction nb1 nb2) - = case (sharePreaction' nb1, sharePreaction' nb2) of - (Nothing, Nothing) -> Nothing - (Just (name1, b1), Nothing) -> Just (name1, b1) - (Nothing, Just (name2, b2)) -> Just (name2, b2) - (Just (name1, b1), Just (name2, b2)) - -> Just (name2, B.concatBody name1 b1 b2) -sharePreaction' EmptyPreaction = Nothing -{-# INLINABLE sharePreaction' #-} - -preactionNames :: Preaction -> [(B.Name, B.Type)] -preactionNames (SimplePreaction name b) = case name of - B.UnusedName -> [] - _ -> case B.instrType $ B.bodyTerm b of - B.IntType 0 -> [] - t -> [(name, t)] -preactionNames (BranchPreaction _ nb1 nb2) - = preactionNames nb1 <> preactionNames nb2 -preactionNames (ConcatPreaction nb1 nb2) - = preactionNames nb1 <> preactionNames nb2 -preactionNames EmptyPreaction = [] -{-# INLINABLE preactionNames #-} +propagate3 :: HasRewriter sig m => Ref -> Ref -> Ref -> (() -> INetF ()) -> m () +propagate3 r0 r1 r2 mk1 = propagate2 r0 r1 mk1 *> propagate1 r2 mk1 +{-# INLINABLE propagate3 #-} + +dedupIO :: HasRewriter sig m => Level -> Ref -> Ref -> Ref -> m () +dedupIO lvl r0 r1 r2 = do + name <- newName + namep <- newName + rn3 <- newNode $ TEntryNode name (B.Constant B.B1) () () + rn4 <- newNode $ TEntryNode name (B.Constant B.B0) () () + rn5 <- newNode $ TBuildNode lvl name namep () () () () + rn6 <- newNode $ AccumIONode mempty () () + linkNodes (Ref rn3 1) (Ref rn5 1) + linkNodes (Ref rn4 1) (Ref rn5 2) + linkNodes (Ref rn5 3) (Ref rn6 0) + propagate1 (Ref rn6 1) $ PrivateRootNode name namep + linkNodes r0 $ Ref rn3 0 + linkNodes r1 $ Ref rn4 0 + linkNodes r2 $ Ref rn5 0 +{-# INLINABLE dedupIO #-} + +reassocPure :: HasRewriter sig m => Ref -> Ref -> m () +reassocPure r0 r1 = do + rn2 <- newNode $ LamNode () () () + rn3 <- newNode $ IOPureNode () () + rn4 <- newNode $ LamNode () () () + rn5 <- newNode $ AppNode () () () + rn6 <- newNode $ LamNode () () () + rn7 <- newNode $ Bind0FNode () () + rn8 <- newNode $ AppNode () () () + rn9 <- newNode $ AppNode () () () + rn10 <- newNode $ BoxNode 0 () () + rn11 <- newNode $ BoxNode 0 () () + rn12 <- newNode $ BoxNode 0 () () + rn13 <- newNode $ BoxNode 0 () () + rn14 <- newNode $ BoxNode 0 () () + linkNodes (Ref rn2 1) (Ref rn13 0) + linkNodes (Ref rn2 2) (Ref rn3 0) + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes (Ref rn4 1) (Ref rn10 0) + linkNodes (Ref rn4 2) (Ref rn5 2) + linkNodes (Ref rn5 0) (Ref rn12 1) + linkNodes (Ref rn5 1) (Ref rn6 0) + linkNodes (Ref rn6 1) (Ref rn9 1) + linkNodes (Ref rn6 2) (Ref rn8 2) + linkNodes (Ref rn7 0) (Ref rn9 2) + linkNodes (Ref rn7 1) (Ref rn8 0) + linkNodes (Ref rn8 1) (Ref rn10 1) + linkNodes (Ref rn9 0) (Ref rn14 1) + linkNodes (Ref rn11 1) (Ref rn12 0) + linkNodes (Ref rn13 1) (Ref rn14 0) + linkNodes r0 $ Ref rn2 0 + linkNodes r1 $ Ref rn11 0 +{-# INLINABLE reassocPure #-} + +-- | @\a -> IOPure (\b -> Bind1F (Bind0F (a op) b))@ +reassocCont :: HasRewriter sig m => B.Instruction -> Ref -> m () +reassocCont instr r0 = do + name <- newName + let op = B.Reference (B.instrType instr) name + rn2 <- newNode $ LamNode () () () + rn3 <- newNode $ IOPureNode () () + rn4 <- newNode $ LamNode () () () + rn5 <- newNode $ Bind1FNode (name B.:= instr) () () + rn6 <- newNode $ Bind0FNode () () + rn7 <- newNode $ AppNode () () () + rn8 <- newNode $ AppNode () () () + rn9 <- newNode $ OperandNode op () + rn10 <- newNode $ BoxNode 0 () () + linkNodes (Ref rn2 1) (Ref rn10 0) + linkNodes (Ref rn2 2) (Ref rn3 0) + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes (Ref rn4 1) (Ref rn7 1) + linkNodes (Ref rn4 2) (Ref rn5 0) + linkNodes (Ref rn5 1) (Ref rn7 2) + linkNodes (Ref rn6 0) (Ref rn8 2) + linkNodes (Ref rn6 1) (Ref rn7 0) + linkNodes (Ref rn8 0) (Ref rn10 1) + linkNodes (Ref rn8 1) (Ref rn9 0) + linkNodes r0 $ Ref rn2 0 +{-# INLINABLE reassocCont #-} mkLambda :: HasRewriter sig m => Ref -> (() -> () -> INetF ()) -> m () mkLambda r0 mk1 = do - rn1 <- newNode $ const $ mk1 () () - rn2 <- newNode $ const $ LamNode () () () + rn1 <- newNode $ mk1 () () + rn2 <- newNode $ LamNode () () () linkNodes (Ref rn1 0) (Ref rn2 1) linkNodes (Ref rn1 1) (Ref rn2 2) linkNodes r0 $ Ref rn2 0 {-# INLINE mkLambda #-} -applyCont :: Preaction -> B.Body -> B.Body -applyCont nbs = case nbs of - SimplePreaction name b -> B.concatBody name b - BranchPreaction op nb1 nb2 -> B.concatBody B.UnusedName - $ B.Body mempty $ B.Branch op (applyCont nb1 eb) (applyCont nb2 eb) - ConcatPreaction nb1 nb2 -> applyCont nb1 . applyCont nb2 - EmptyPreaction -> id - where - eb = B.Body mempty $ B.Pure B.Empty -{-# INLINABLE applyCont #-} - -renamePreaction :: M.Map B.Name B.Operand -> Preaction -> Preaction -renamePreaction re nbs = case nbs of - SimplePreaction name b - -> SimplePreaction name (B.renameBody re b) - BranchPreaction opc bt bf -> BranchPreaction - (B.renameOp re opc) (renamePreaction re bt) (renamePreaction re bf) - ConcatPreaction b1 b2 - -> ConcatPreaction (renamePreaction re b1) (renamePreaction re b2) - EmptyPreaction -> EmptyPreaction -{-# INLINABLE renamePreaction #-} - -mkName :: Int -> B.Name -mkName = B.Name . fromIntegral -{-# INLINE mkName #-} - -mkRef :: B.Type -> Int -> B.Operand -mkRef t = B.Reference t . mkName -{-# INLINE mkRef #-} - mkSelect :: B.Operand -> B.Operand -> B.Operand -> B.Operand +mkSelect (B.Constant bitc) opt opf = case bitc of + B.B0 -> opf + B.B1 -> opt mkSelect opc (B.Constant B.B1) (B.Constant B.B0) = opc mkSelect opc opt opf | opt == opf = opt | otherwise = B.Select opc opt opf {-# INLINABLE mkSelect #-} -mkGetElement :: Int -> B.Operand -> B.Operand -mkGetElement idx (B.Tuple ops) = ops !! idx -mkGetElement idx opt = B.GetElement idx opt -{-# INLINABLE mkGetElement #-} +mkChurchBool :: HasRewriter sig m => (m () -> m () -> m ()) -> m Ref +mkChurchBool sel = do + rn1 <- newNode $ LamNode () () () + rn2 <- newNode $ LamNode () () () + rn3 <- newNode $ DeadNode () + linkNodes (Ref rn1 2) (Ref rn2 0) + sel (mkTrue rn1 rn2 rn3) (mkFalse rn1 rn2 rn3) + pure $ Ref rn1 0 + where + mkTrue rn1 rn2 rn3 = do + rn4 <- newNode $ BoxNode 0 () () + linkNodes (Ref rn2 1) (Ref rn3 0) + linkNodes (Ref rn1 1) (Ref rn4 0) + linkNodes (Ref rn2 2) (Ref rn4 1) + + mkFalse rn1 rn2 rn3 = do + linkNodes (Ref rn1 1) (Ref rn3 0) + linkNodes (Ref rn2 1) (Ref rn2 2) +{-# INLINABLE mkChurchBool #-} type HasRewriter sig m = (Has (State INet) sig m, Has (State INetPairs) sig m , Has (State INetSize) sig m) @@ -1006,16 +1073,23 @@ _INetSize :: Iso' INetSize Int _INetSize = iso unINetSize INetSize {-# INLINE _INetSize #-} --- TODO: See if removing the self-reference from the constructor is possible. -newNode :: HasRewriter sig m => (Int -> INetF ()) -> m Int +newNode :: HasRewriter sig m => INetF () -> m Int newNode mk = do idx <- newNodeIndex - modify $ _INet . at idx ?~ (unsetRef <$ mk idx) + modify $ _INet . at idx ?~ (unsetRef <$ mk) pure idx where unsetRef = Ref (-1) (-1) {-# INLINE newNode #-} +newName :: HasRewriter sig m => m B.Name +newName = B.Name <$> newNodeIndex +{-# INLINE newName #-} + +newLabel :: HasRewriter sig m => m B.Label +newLabel = B.Label <$> newNodeIndex +{-# INLINE newLabel #-} + newNodeIndex :: Has (State INetSize) sig m => m Int newNodeIndex = gets unINetSize <* modify @INetSize succ {-# INLINE newNodeIndex #-} @@ -1038,7 +1112,30 @@ linkNodes r0 r1 = do >>= (^? folded . to refNode) {-# INLINE linkNodes #-} +-- | Deletes all 'BoxNode' from the graph. Helps unclutter debugging output. +deleteBoxes :: HasRewriter sig m => m () +deleteBoxes = do + size <- gets unINetSize + go size 0 + where + go size rn0 + | rn0 < size = do + net <- gets unINet + case net IM.!? rn0 of + Just (BoxNode _ r1 r2) -> do + linkNodes r1 r2 + modify $ _INet . at rn0 .~ Nothing + _ -> pure () + go size $ succ rn0 + | otherwise = pure () +{-# INLINABLE deleteBoxes #-} + +-- | Effect for tracing rewrites. data TraceRewrite m a where + {-| + The @m r@ continuation performs a rewrite on the @'INetF' 'Ref'@ nodes. + The 'Ref's refer to the principal ports of the nodes. + -} TraceRewrite :: Ref -> Ref -> INetF Ref -> INetF Ref -> m r -> TraceRewrite m r diff --git a/src/Language/Elemental/Pretty.hs b/src/Language/Elemental/Pretty.hs index 774abdc..37ce25f 100644 --- a/src/Language/Elemental/Pretty.hs +++ b/src/Language/Elemental/Pretty.hs @@ -73,9 +73,14 @@ prettyExpr = flip $ \case Lam tx ey -> withPrec 0 $ "λ" <> prettyType 2 tx <+> prettyExpr 0 ey TypeLam ex -> withPrec 0 $ "Λ" <+> prettyExpr 0 ex Addr addr _ _ -> withPrec 3 $ braces $ "addr" <+> pretty addr - BackendOperand lt _ -> withPrec 3 $ braces $ "op" <+> prettyBackendType lt - BackendIO lt _ -> withPrec 3 $ braces $ "io op" <+> prettyBackendType lt + BackendOperand lt op + -> withPrec 3 $ braces $ "op" <+> prettyBackendType lt <+> pretty op + BackendIO lt b + -> withPrec 3 $ braces $ "io op" <+> prettyBackendType lt <+> pretty b BackendPIO lt _ _ -> withPrec 3 $ braces $ "iop op" <+> prettyBackendType lt + -- ContIO t cont -> withPrec 3 $ braces $ "contIO" <+> prettyType 2 t + -- -- This might not be the correct type, but seeing into 'ContIO' helps. + -- <+> prettyExpr 2 (cont $ SBackendInt SZero) PureIO -> withPrec 3 $ braces "pureIO" BindIO -> withPrec 3 $ braces "bindIO" LoadPointer -> withPrec 3 $ braces "loadPointer" @@ -88,6 +93,7 @@ prettyExpr = flip $ \case InsertBit size -> withPrec 3 $ braces $ "insert" <+> prettyBackendType (SBackendInt size) TestBit -> withPrec 3 $ braces "testBit" + -- TestBit _ -> withPrec 3 $ braces "testBit" -- | Prettyprints a type with the given precedence. prettyType :: Int -> SType tscope t -> Doc ann diff --git a/test/Golden.hs b/test/Golden.hs index aa8c8fa..5893b92 100644 --- a/test/Golden.hs +++ b/test/Golden.hs @@ -13,8 +13,10 @@ module Golden where import Control.Algebra (Algebra(alg), Has, (:+:)(L, R), run) import Control.Carrier.Reader (ReaderC(ReaderC), runReader) -import Control.Carrier.State.Church (State, evalState, get, gets, modify) -import Control.Lens (Iso', iso, ix, (^?), (%~)) +import Control.Carrier.State.Church + (State, evalState, get, gets, modify, runState) +import Control.Lens (Fold, Iso', at, iso, ix, to, (^?), (%~), (^..)) +import Control.Monad (when) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL @@ -22,6 +24,7 @@ import Data.Foldable (traverse_) import Data.Functor.Identity (Identity) import Data.IntMap qualified as IM import Data.IntSet qualified as IS +import Data.Map.Strict qualified as M import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Text.Short qualified as TS @@ -32,9 +35,11 @@ import LLVM.Module (File(File), moduleLLVMAssembly, withModuleFromAST, writeLLVMAssemblyToFile) import LLVM.PassManager (runPassManager, withPassManager) import LLVM.PassManager qualified as LLVM.Pass +import LLVM.Transforms qualified as LLVM.Opt import Prettyprinter - ( Doc, PageWidth(Unbounded) - , defaultLayoutOptions, layoutPageWidth, layoutPretty, line, nest, pretty, (<+>) + ( Doc, PageWidth(Unbounded), Pretty + , defaultLayoutOptions, layoutPageWidth, layoutPretty + , line, nest, pretty, vcat, (<+>) ) import Prettyprinter.Render.Text (renderIO) import System.FilePath (replaceExtension, takeBaseName) @@ -72,10 +77,10 @@ compileFile file = runGolden $ \lh -> do liftIO $ withFile (replaceExtension file ".inet") WriteMode $ \h -> hPutDoc h $ pretty graph liftIO $ hPutStrLn lh "Interpreting" - gen <- compileINet exts + bprog <- compileINet exts graph' <- get @INet liftIO $ hPutStrLn lh "Translating" - let llvmDefs = compileProgram gen + let llvmDefs = compileProgram bprog llvm = defaultModule { moduleSourceFileName = TS.toShortByteString $ TS.fromString file , moduleDefinitions = llvmDefs @@ -84,9 +89,10 @@ compileFile file = runGolden $ \lh -> do withFile (replaceExtension file ".opt.inet") WriteMode $ \h -> hPutDoc h $ pretty graph' withFile (replaceExtension file ".hl") WriteMode - $ \h -> hPutDoc h $ pretty gen + $ \h -> hPutDoc h $ pretty bprog withContext $ \ctx -> withModuleFromAST ctx llvm - $ \m -> withPassManager passes $ \pm -> do + $ \m -> withPassManager passes $ \pm + -> withPassManager passes' $ \pm' -> do -- writeLLVMAssemblyToFile doesn't truncate the file. () <- withFile (replaceExtension file ".ll") WriteMode mempty writeLLVMAssemblyToFile (File $ replaceExtension file ".ll") m @@ -97,10 +103,13 @@ compileFile file = runGolden $ \lh -> do and once isn't enough. -} _ <- runPassManager pm m + _ <- runPassManager pm' m _ <- runPassManager pm m _ <- runPassManager pm m + _ <- runPassManager pm' m _ <- runPassManager pm m _ <- runPassManager pm m + _ <- runPassManager pm' m BSL.fromStrict <$> moduleLLVMAssembly m where parseSource :: T.Text -> IO PProgram @@ -112,7 +121,9 @@ compileFile file = runGolden $ \lh -> do -> evalState @INet mempty $ evalState @INetPairs mempty $ evalState @INetSize 0 - $ evalState @Count 0 + $ runState @Count (flip (<$) . liftIO . hPrint lh . (<+>) "Total" + . pretty . unCount) 0 + $ runState @Stats (flip (<$) . liftIO . hPrint lh . pretty) mempty $ runReader @Level 0 $ runTraceRewrite <*> m $ lh @@ -136,6 +147,18 @@ passes = LLVM.Pass.CuratedPassSetSpec , LLVM.Pass.targetMachine = Nothing } +-- CuratedPassSetSpec O3 doesn't apply -inline even though opt -O3 does. +passes' :: LLVM.Pass.PassSetSpec +passes' = LLVM.Pass.PassSetSpec + { LLVM.Pass.transforms = + [ LLVM.Opt.PartialInlining + , LLVM.Opt.FunctionInlining 225 + ] + , LLVM.Pass.dataLayout = Nothing + , LLVM.Pass.targetLibraryInfo = Nothing + , LLVM.Pass.targetMachine = Nothing + } + newtype TraceRewriteC m a = TraceRewriteC (Handle -> m a) deriving (Functor, Applicative, Monad, MonadIO) via ReaderC Handle m @@ -144,7 +167,8 @@ runTraceRewrite h (TraceRewriteC f) = f h {-# INLINE runTraceRewrite #-} instance (MonadIO m, Has (State Count) sig m, Has (State INet) sig m - , Has (State INetPairs) sig m, Has (State INetSize) sig m) + , Has (State INetPairs) sig m, Has (State INetSize) sig m + , Has (State Stats) sig m) => Algebra (TraceRewrite :+: sig) (TraceRewriteC m) where alg hdl sig ctx = TraceRewriteC $ \h -> case sig of @@ -152,24 +176,57 @@ instance (MonadIO m, Has (State Count) sig m, Has (State INet) sig m size0 <- gets unINetSize r <- runTraceRewrite h . hdl $ cont <$ ctx lint size0 n0 n1 + let nh0 = nodeHead n0 + nh1 = nodeHead n1 + statKey = if nh0 < nh1 then (nh0, nh1) else (nh1, nh0) modify $ _Count %~ succ + modify $ _Stats . at statKey %~ Just . maybe 1 succ count <- gets unCount netSize <- gets (IM.size . unINet) pairsSize <- gets (IS.size . unINetPairs) - liftIO $ hPrint h - $ pretty count - <+> pretty netSize - <+> pretty pairsSize - <+> pretty size0 - <> nest 4 (line <> pretty n0 <> line <> pretty n1) + case (n0, n1) of + -- These nodes are extremely abundant and usually uninteresting. + (LamNode {}, _) -> pure () + (_, LamNode {}) -> pure () + (AppNode {}, DupNode {}) -> pure () + (DupNode {}, AppNode {}) -> pure () + (DupNode {}, DupNode {}) -> pure () + (DeadNode {}, _) -> pure () + (_, DeadNode {}) -> pure () + (BoxNode {}, _) -> pure () + (_, BoxNode {}) -> pure () + -- These nodes might require prettyprinting very large blocks. + (AccumNBNode {}, _) -> pure () + (_, AccumNBNode {}) -> pure () + (IONode {}, _) -> pure () + (_, IONode {}) -> pure () + (NamedBlockNode {}, _) -> pure () + (_, NamedBlockNode {}) -> pure () + (Merge1Node {}, _) -> pure () + (_, Merge1Node {}) -> pure () + _ -> liftIO $ hPrint h + $ pretty count + <+> pretty netSize + <+> pretty pairsSize + <+> pretty size0 + <> nest 4 (line <> pretty n0 <> line <> pretty n1) + when (count > 1000000) $ do + stats <- get @Stats + liftIO $ hPrint h $ pretty stats + error "too much work, giving up" pure r R other -> alg (runTraceRewrite h . hdl) other ctx where - lint :: Has (State INet) sig m => Int -> INetF Ref -> INetF Ref -> m () - lint size n0 n1 - = gets unINet >>= (traverse_ . traverse) lintRef + lint :: HasRewriter sig m => Int -> INetF Ref -> INetF Ref -> m () + lint size n0 n1 = do + net <- gets unINet + (traverse_ . traverse) lintRef . snd $ IM.split (pred size) net + let f :: Fold (INetF Ref) Ref + f = traverse . to ((net IM.!?) . refNode) . traverse . traverse + traverse_ lintRef $ n0 ^.. f + traverse_ lintRef $ n1 ^.. f where - lintRef :: Has (State INet) sig m => Ref -> m () + lintRef :: HasRewriter sig m => Ref -> m () lintRef (Ref (-1) (-1)) = abort "uninitialised ref" lintRef r3 = do net <- get @INet @@ -179,8 +236,9 @@ instance (MonadIO m, Has (State Count) sig m, Has (State INet) sig m Nothing -> abort $ "missing port:" <+> pretty r3 Just _ -> pure () - abort :: Has (State INet) sig m => Doc ann -> m a + abort :: HasRewriter sig m => Doc ann -> m a abort msg = do + deleteBoxes net <- get @INet error . show $ "lint:" <+> msg <> line <> "Size before reduction was" <+> pretty size @@ -196,6 +254,101 @@ _Count :: Iso' Count Int _Count = iso unCount Count {-# INLINE _Count #-} +newtype Stats = Stats { unStats :: M.Map (NodeHead, NodeHead) Int } + deriving newtype (Eq, Ord, Monoid, Semigroup) + +instance Pretty Stats where + pretty + = vcat . (uncurry ((. pretty) . (<+>) + . uncurry ((. pretty) . (<+>) . pretty)) <$>) + . M.assocs . unStats + +_Stats :: Iso' Stats (M.Map (NodeHead, NodeHead) Int) +_Stats = iso unStats Stats +{-# INLINE _Stats #-} + +data NodeHead + = AppHead | LamHead | DupHead | DeadHead | BoxHead + | ExternalRootHead | PrivateRootHead | AccumIOHead | AccumNBHead + | OperandHead | OperandPHead + | IOHead | IOPHead | IOPureHead | IOContHead + | ReturnHead + | Bind0BHead | Bind0FHead | Bind1FHead + | Branch0Head | Branch0FHead | Branch1Head + | LabelHead | NamedBlockHead | Merge0Head | Merge1Head + | TBuildHead | TEntryHead | TSplitHead + | TCloseHead | TLeaveHead | TMatchHead + deriving stock (Eq, Ord) + +instance Pretty NodeHead where + pretty AppHead = "App" + pretty LamHead = "Lam" + pretty DupHead = "Dup" + pretty DeadHead = "Dead" + pretty ExternalRootHead = "ExternalRoot" + pretty PrivateRootHead = "PrivateRoot" + pretty AccumIOHead = "AccumIO" + pretty AccumNBHead = "AccumNB" + pretty BoxHead = "Box" + pretty OperandHead = "Operand" + pretty OperandPHead = "OperandP" + pretty IOHead = "IO" + pretty IOPHead = "IOP" + pretty IOPureHead = "IOPure" + pretty IOContHead = "IOCont" + pretty ReturnHead = "Return" + pretty Bind0BHead = "Bind0B" + pretty Bind0FHead = "Bind0F" + pretty Bind1FHead = "Bind1F" + pretty Branch0Head = "Branch0" + pretty Branch0FHead = "Branch0F" + pretty Branch1Head = "Branch1" + pretty LabelHead = "Label" + pretty NamedBlockHead = "NamedBlock" + pretty Merge0Head = "Merge0" + pretty Merge1Head = "Merge1" + pretty TBuildHead = "TBuild" + pretty TEntryHead = "TEntry" + pretty TSplitHead = "TSplit" + pretty TCloseHead = "TClose" + pretty TLeaveHead = "TLeave" + pretty TMatchHead = "TMatch" + +nodeHead :: INetF a -> NodeHead +nodeHead x = case x of + AppNode {} -> AppHead + LamNode {} -> LamHead + DupNode {} -> DupHead + DeadNode {} -> DeadHead + BoxNode {} -> BoxHead + ExternalRootNode {} -> ExternalRootHead + PrivateRootNode {} -> PrivateRootHead + AccumIONode {} -> AccumIOHead + AccumNBNode {} -> AccumNBHead + OperandNode {} -> OperandHead + OperandPNode {} -> OperandPHead + IONode {} -> IOHead + IOPNode {} -> IOPHead + IOPureNode {} -> IOPureHead + IOContNode {} -> IOContHead + ReturnNode {} -> ReturnHead + Bind0BNode {} -> Bind0BHead + Bind0FNode {} -> Bind0FHead + Bind1FNode {} -> Bind1FHead + Branch0Node {} -> Branch0Head + Branch0FNode {} -> Branch0FHead + Branch1Node {} -> Branch1Head + LabelNode {} -> LabelHead + NamedBlockNode {} -> NamedBlockHead + Merge0Node {} -> Merge0Head + Merge1Node {} -> Merge1Head + TBuildNode {} -> TBuildHead + TEntryNode {} -> TEntryHead + TSplitNode {} -> TSplitHead + TCloseNode {} -> TCloseHead + TLeaveNode {} -> TLeaveHead + TMatchNode {} -> TMatchHead + hPutDoc :: Handle -> Doc ann -> IO () hPutDoc h doc = renderIO h $ layoutPretty opts doc where diff --git a/test/Golden/Arithmetic.elem b/test/Golden/Arithmetic.elem new file mode 100644 index 0000000..68c4d46 --- /dev/null +++ b/test/Golden/Arithmetic.elem @@ -0,0 +1,97 @@ +foreign export "expsign" c_expsign + : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + → (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + → IO (∀ 0 → 0 → 0) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +zero = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (nothing @0) +succ = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (just @0 (1 @0 0)) + +nothing = Λ Λ λ0 λ(1 → 0) 1 +just = Λ λ0 Λ λ0 λ(1 → 0) 0 2 + +f = Λ λ0 λ0 0 +t = Λ λ0 λ0 1 + +add = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 1 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (λ(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 1 succ) + +mul = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 1 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (λ(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) zero (add 1)) + +exp = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (λ(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (succ zero) (mul 2)) + +isOdd = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 0 @(∀ 0 → 0 → 0) (λ(∀ 0 → ((∀ 0 → 0 → 0) → 0) → 0) + 0 @(∀ 0 → 0 → 0) f not) + +not = λ(∀ 0 → 0 → 0) Λ λ0 λ0 2 @0 0 1 + +from2 = λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + (λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) + add (from1 0) (mul (succ (succ zero)) (from1 1))) + +from1 = λ(∀ 0 → 0 → 0) 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (succ zero) zero + +c_expsign = λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + pureIO @(∀ 0 → 0 → 0) (isOdd (exp (from2 1) (from2 0))) + -- pureIO @(∀ 0 → 0 → 0) (isOdd (add (from2 1) (from2 0))) + +{- +to8 = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) _ + +c_exp = λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + pureIO @(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + (to8 (exp (from8 1) (from8 0))) + +pred = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 0 @(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + (λ(∀ 0 → ((∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) → 0) → 0) + 0 @(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + (nothing @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0)) + (λ(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + 0 @(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + (just @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) zero) + (λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + just @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (succ 0)))) + +sub = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 0 @(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + (λ(∀ 0 → ((∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) → 0) → 0) + 0 @(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + (just @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) 2) + (λ(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + 0 @(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + (nothing @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0)) + pred)) +-} + +{- +mod = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 1 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (λ(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) zero (succMod 1)) + +-- succMod a b = "(succ b) mod a" if b = "b mod a" +succMod = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + eq (succ 0) 1 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) zero (succ 0) + +eq = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) (λ(∀ 0 → ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → 0) → 0) + 0 @(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) isZero isSucc) + +isZero = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 0 @(∀ 0 → 0 → 0) t (λ(∀ 0 → 0 → 0) f) + +isSucc = λ((∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) → ∀ 0 → 0 → 0) λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) + 0 @(∀ 0 → 0 → 0) f (λ(∀ 0 → 0 → 0) _) +-} + diff --git a/test/Golden/Arithmetic.opt.ll b/test/Golden/Arithmetic.opt.ll new file mode 100644 index 0000000..ee57b50 --- /dev/null +++ b/test/Golden/Arithmetic.opt.ll @@ -0,0 +1,13 @@ +; ModuleID = '' +source_filename = "test/Golden/Arithmetic.elem" + +; Function Attrs: norecurse nounwind readnone +define i1 @expsign(i2, i2) local_unnamed_addr #0 { + %3 = and i2 %0, 1 + %4 = icmp ne i2 %3, 0 + %5 = icmp eq i2 %1, 0 + %spec.select11 = or i1 %5, %4 + ret i1 %spec.select11 +} + +attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/BitOrder.opt.ll b/test/Golden/BitOrder.opt.ll index 0fc962b..ce2b20f 100644 --- a/test/Golden/BitOrder.opt.ll +++ b/test/Golden/BitOrder.opt.ll @@ -3,8 +3,17 @@ source_filename = "test/Golden/BitOrder.elem" ; Function Attrs: norecurse nounwind readnone define i2 @main(i2) local_unnamed_addr #0 { - %2 = xor i2 %0, 1 - ret i2 %2 + %2 = icmp sgt i2 %0, -1 + %3 = and i2 %0, 1 + br i1 %2, label %6, label %4 + +4: ; preds = %1 + %5 = xor i2 %3, -1 + ret i2 %5 + +6: ; preds = %1 + %7 = xor i2 %3, 1 + ret i2 %7 } attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/BranchIO.elem b/test/Golden/BranchIO.elem new file mode 100644 index 0000000..b768e85 --- /dev/null +++ b/test/Golden/BranchIO.elem @@ -0,0 +1,7 @@ +foreign import c_t "t" : IO (∀ 0 → 0) +foreign import c_f "f" : IO (∀ 0 → 0) + +foreign export "main" main : (∀ 0 → 0 → 0) → IO (∀ 0 → 0) + +main = λ(∀ 0 → 0 → 0) 0 @(IO (∀ 0 → 0)) c_t c_f + diff --git a/test/Golden/BranchIO.opt.ll b/test/Golden/BranchIO.opt.ll new file mode 100644 index 0000000..8eac301 --- /dev/null +++ b/test/Golden/BranchIO.opt.ll @@ -0,0 +1,18 @@ +; ModuleID = '' +source_filename = "test/Golden/BranchIO.elem" + +declare void @t() local_unnamed_addr + +declare void @f() local_unnamed_addr + +define void @main(i1) local_unnamed_addr { + br i1 %0, label %2, label %3 + +2: ; preds = %1 + tail call void @t() + ret void + +3: ; preds = %1 + tail call void @f() + ret void +} diff --git a/test/Golden/CallOrder.opt.ll b/test/Golden/CallOrder.opt.ll index 9b072ab..05d1326 100644 --- a/test/Golden/CallOrder.opt.ll +++ b/test/Golden/CallOrder.opt.ll @@ -4,6 +4,61 @@ source_filename = "test/Golden/CallOrder.elem" declare void @dothing(i2, i1) local_unnamed_addr define void @main(i2, i1) local_unnamed_addr { - tail call void @dothing(i2 %0, i1 %1) + %3 = icmp sgt i2 %0, -1 + %4 = and i2 %0, 1 + %5 = icmp eq i2 %4, 0 + br i1 %3, label %12, label %6 + +6: ; preds = %2 + br i1 %5, label %9, label %codeRepl.i + +codeRepl.i: ; preds = %6 + br i1 %1, label %7, label %8 + +7: ; preds = %codeRepl.i + tail call void @dothing(i2 -1, i1 true) + br label %__elem_0.1.exit + +8: ; preds = %codeRepl.i + tail call void @dothing(i2 -1, i1 false) + br label %__elem_0.1.exit + +9: ; preds = %6 + br i1 %1, label %10, label %11 + +10: ; preds = %9 + tail call void @dothing(i2 -2, i1 true) + br label %__elem_0.1.exit + +11: ; preds = %9 + tail call void @dothing(i2 -2, i1 false) + br label %__elem_0.1.exit + +__elem_0.1.exit: ; preds = %16, %17, %14, %13, %10, %11, %8, %7 ret void + +12: ; preds = %2 + br i1 %5, label %15, label %codeRepl.i1 + +codeRepl.i1: ; preds = %12 + br i1 %1, label %13, label %14 + +13: ; preds = %codeRepl.i1 + tail call void @dothing(i2 1, i1 true) + br label %__elem_0.1.exit + +14: ; preds = %codeRepl.i1 + tail call void @dothing(i2 1, i1 false) + br label %__elem_0.1.exit + +15: ; preds = %12 + br i1 %1, label %16, label %17 + +16: ; preds = %15 + tail call void @dothing(i2 0, i1 true) + br label %__elem_0.1.exit + +17: ; preds = %15 + tail call void @dothing(i2 0, i1 false) + br label %__elem_0.1.exit } diff --git a/test/Golden/CataDynamic.opt.ll b/test/Golden/CataDynamic.opt.ll index b30b758..669ab8f 100644 --- a/test/Golden/CataDynamic.opt.ll +++ b/test/Golden/CataDynamic.opt.ll @@ -6,13 +6,13 @@ declare void @dothing() local_unnamed_addr define void @main(i1) local_unnamed_addr { tail call void @dothing() tail call void @dothing() - br i1 %0, label %3, label %2 + br i1 %0, label %2, label %3 2: ; preds = %1 + ret void + +3: ; preds = %1 tail call void @dothing() tail call void @dothing() - br label %3 - -3: ; preds = %1, %2 ret void } diff --git a/test/Golden/CataStaticAccum.elem b/test/Golden/CataStaticAccum.elem new file mode 100644 index 0000000..f1c6e27 --- /dev/null +++ b/test/Golden/CataStaticAccum.elem @@ -0,0 +1,27 @@ +foreign export "main" main : IO (∀ 0 → 0 → 0) + +main = count @(IO (∀ 0 → 0 → 0)) (λ(∀ 0 → (IO (∀ 0 → 0 → 0) → 0) → 0) + 0 @(IO (∀ 0 → 0 → 0)) + (pureIO @(∀ 0 → 0 → 0) f) + (λ(IO (∀ 0 → 0 → 0)) bindIO + @(∀ 0 → 0 → 0) 0 + @(∀ 0 → 0 → 0) (λ(∀ 0 → 0 → 0) bindIO + @(∀ 0 → 0 → 0) c_dothing + @(∀ 0 → 0 → 0) (λ(∀ 0 → 0 → 0) pureIO @(∀ 0 → 0 → 0) (xor 1 0)))) + ) + +xor = λ(∀ 0 → 0 → 0) 0 @((∀ 0 → 0 → 0) → ∀ 0 → 0 → 0) not (λ(∀ 0 → 0 → 0) 0) +not = λ(∀ 0 → 0 → 0) Λ λ0 λ0 2 @0 0 1 + +f = Λ λ0 λ0 0 +t = Λ λ0 λ0 1 + +count = succ (succ (succ zero)) + +zero = Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 1) +succ = λ(∀ ((∀ 0 → (1 → 0) → 0) → 0) → 0) Λ λ((∀ 0 → (1 → 0) → 0) → 0) 0 (Λ λ0 λ(1 → 0) 0 (3 @1 2)) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +foreign import c_dothing "dothing" : IO (∀ 0 → 0 → 0) diff --git a/test/Golden/CataStaticAccum.opt.ll b/test/Golden/CataStaticAccum.opt.ll new file mode 100644 index 0000000..1598216 --- /dev/null +++ b/test/Golden/CataStaticAccum.opt.ll @@ -0,0 +1,14 @@ +; ModuleID = '' +source_filename = "test/Golden/CataStaticAccum.elem" + +declare i1 @dothing() local_unnamed_addr + +define i1 @main() local_unnamed_addr { +__elem_2.exit: + %0 = tail call i1 @dothing() + %1 = tail call i1 @dothing() + %2 = tail call i1 @dothing() + %spec.select = xor i1 %0, %1 + %3 = xor i1 %2, %spec.select + ret i1 %3 +} diff --git a/test/Golden/EchoChar.opt.ll b/test/Golden/EchoChar.opt.ll index ce1292d..8996a3e 100644 --- a/test/Golden/EchoChar.opt.ll +++ b/test/Golden/EchoChar.opt.ll @@ -6,10 +6,1925 @@ declare void @putchar(i8) local_unnamed_addr ; Function Attrs: nofree nounwind declare i8 @getchar() local_unnamed_addr #0 +define private fastcc void @__elem_2(i1, i8, i1, i1) unnamed_addr { + %5 = and i8 %1, 16 + %6 = icmp eq i8 %5, 0 + %7 = and i8 %1, 8 + %8 = icmp eq i8 %7, 0 + br i1 %6, label %11, label %9 + +9: ; preds = %4 + br i1 %8, label %10, label %codeRepl.i + +codeRepl.i: ; preds = %9 + tail call fastcc void @__elem_4(i1 true, i8 %1, i1 %2, i1 %3, i1 %0, i1 true) + br label %__elem_3.2.exit + +10: ; preds = %9 + tail call fastcc void @__elem_4(i1 false, i8 %1, i1 %2, i1 %3, i1 %0, i1 true) + br label %__elem_3.2.exit + +__elem_3.2.exit: ; preds = %codeRepl.i1, %12, %10, %codeRepl.i + ret void + +11: ; preds = %4 + br i1 %8, label %12, label %codeRepl.i1 + +codeRepl.i1: ; preds = %11 + tail call fastcc void @__elem_4(i1 true, i8 %1, i1 %2, i1 %3, i1 %0, i1 false) + br label %__elem_3.2.exit + +12: ; preds = %11 + tail call fastcc void @__elem_4(i1 false, i8 %1, i1 %2, i1 %3, i1 %0, i1 false) + br label %__elem_3.2.exit +} + +define private fastcc void @__elem_4(i1, i8, i1, i1, i1, i1) unnamed_addr { + %7 = and i8 %1, 4 + %8 = icmp eq i8 %7, 0 + %9 = and i8 %1, 2 + %10 = icmp eq i8 %9, 0 + br i1 %8, label %13, label %11 + +11: ; preds = %6 + br i1 %10, label %12, label %codeRepl.i + +codeRepl.i: ; preds = %11 + tail call fastcc void @__elem_6(i1 true, i8 %1, i1 %2, i1 %3, i1 %4, i1 %5, i1 %0, i1 true) + br label %__elem_5.1.exit + +12: ; preds = %11 + tail call fastcc void @__elem_6(i1 false, i8 %1, i1 %2, i1 %3, i1 %4, i1 %5, i1 %0, i1 true) + br label %__elem_5.1.exit + +__elem_5.1.exit: ; preds = %codeRepl.i1, %14, %12, %codeRepl.i + ret void + +13: ; preds = %6 + br i1 %10, label %14, label %codeRepl.i1 + +codeRepl.i1: ; preds = %13 + tail call fastcc void @__elem_6(i1 true, i8 %1, i1 %2, i1 %3, i1 %4, i1 %5, i1 %0, i1 false) + br label %__elem_5.1.exit + +14: ; preds = %13 + tail call fastcc void @__elem_6(i1 false, i8 %1, i1 %2, i1 %3, i1 %4, i1 %5, i1 %0, i1 false) + br label %__elem_5.1.exit +} + +define private fastcc void @__elem_6(i1, i8, i1, i1, i1, i1, i1, i1) unnamed_addr { + %9 = and i8 %1, 1 + %10 = icmp eq i8 %9, 0 + br i1 %10, label %12, label %11 + +11: ; preds = %8 + br i1 %2, label %13, label %14 + +12: ; preds = %8 + br i1 %2, label %15, label %16 + +13: ; preds = %11 + br i1 %3, label %17, label %18 + +14: ; preds = %11 + br i1 %3, label %47, label %48 + +15: ; preds = %12 + br i1 %3, label %77, label %78 + +16: ; preds = %12 + br i1 %3, label %107, label %108 + +17: ; preds = %13 + br i1 %4, label %19, label %20 + +18: ; preds = %13 + br i1 %4, label %33, label %34 + +19: ; preds = %17 + br i1 %5, label %21, label %22 + +20: ; preds = %17 + br i1 %5, label %27, label %28 + +21: ; preds = %19 + br i1 %6, label %23, label %24 + +22: ; preds = %19 + br i1 %6, label %25, label %26 + +23: ; preds = %21 + br i1 %7, label %137, label %138 + +24: ; preds = %21 + br i1 %7, label %139, label %140 + +25: ; preds = %22 + br i1 %7, label %141, label %142 + +26: ; preds = %22 + br i1 %7, label %143, label %144 + +27: ; preds = %20 + br i1 %6, label %29, label %30 + +28: ; preds = %20 + br i1 %6, label %31, label %32 + +29: ; preds = %27 + br i1 %7, label %145, label %146 + +30: ; preds = %27 + br i1 %7, label %147, label %148 + +31: ; preds = %28 + br i1 %7, label %149, label %150 + +32: ; preds = %28 + br i1 %7, label %151, label %152 + +33: ; preds = %18 + br i1 %5, label %35, label %36 + +34: ; preds = %18 + br i1 %5, label %41, label %42 + +35: ; preds = %33 + br i1 %6, label %37, label %38 + +36: ; preds = %33 + br i1 %6, label %39, label %40 + +37: ; preds = %35 + br i1 %7, label %153, label %154 + +38: ; preds = %35 + br i1 %7, label %155, label %156 + +39: ; preds = %36 + br i1 %7, label %157, label %158 + +40: ; preds = %36 + br i1 %7, label %159, label %160 + +41: ; preds = %34 + br i1 %6, label %43, label %44 + +42: ; preds = %34 + br i1 %6, label %45, label %46 + +43: ; preds = %41 + br i1 %7, label %161, label %162 + +44: ; preds = %41 + br i1 %7, label %163, label %164 + +45: ; preds = %42 + br i1 %7, label %165, label %166 + +46: ; preds = %42 + br i1 %7, label %167, label %168 + +47: ; preds = %14 + br i1 %4, label %49, label %50 + +48: ; preds = %14 + br i1 %4, label %63, label %64 + +49: ; preds = %47 + br i1 %5, label %51, label %52 + +50: ; preds = %47 + br i1 %5, label %57, label %58 + +51: ; preds = %49 + br i1 %6, label %53, label %54 + +52: ; preds = %49 + br i1 %6, label %55, label %56 + +53: ; preds = %51 + br i1 %7, label %169, label %170 + +54: ; preds = %51 + br i1 %7, label %171, label %172 + +55: ; preds = %52 + br i1 %7, label %173, label %174 + +56: ; preds = %52 + br i1 %7, label %175, label %176 + +57: ; preds = %50 + br i1 %6, label %59, label %60 + +58: ; preds = %50 + br i1 %6, label %61, label %62 + +59: ; preds = %57 + br i1 %7, label %177, label %178 + +60: ; preds = %57 + br i1 %7, label %179, label %180 + +61: ; preds = %58 + br i1 %7, label %181, label %182 + +62: ; preds = %58 + br i1 %7, label %183, label %184 + +63: ; preds = %48 + br i1 %5, label %65, label %66 + +64: ; preds = %48 + br i1 %5, label %71, label %72 + +65: ; preds = %63 + br i1 %6, label %67, label %68 + +66: ; preds = %63 + br i1 %6, label %69, label %70 + +67: ; preds = %65 + br i1 %7, label %185, label %186 + +68: ; preds = %65 + br i1 %7, label %187, label %188 + +69: ; preds = %66 + br i1 %7, label %189, label %190 + +70: ; preds = %66 + br i1 %7, label %191, label %192 + +71: ; preds = %64 + br i1 %6, label %73, label %74 + +72: ; preds = %64 + br i1 %6, label %75, label %76 + +73: ; preds = %71 + br i1 %7, label %193, label %194 + +74: ; preds = %71 + br i1 %7, label %195, label %196 + +75: ; preds = %72 + br i1 %7, label %197, label %198 + +76: ; preds = %72 + br i1 %7, label %199, label %200 + +77: ; preds = %15 + br i1 %4, label %79, label %80 + +78: ; preds = %15 + br i1 %4, label %93, label %94 + +79: ; preds = %77 + br i1 %5, label %81, label %82 + +80: ; preds = %77 + br i1 %5, label %87, label %88 + +81: ; preds = %79 + br i1 %6, label %83, label %84 + +82: ; preds = %79 + br i1 %6, label %85, label %86 + +83: ; preds = %81 + br i1 %7, label %201, label %202 + +84: ; preds = %81 + br i1 %7, label %203, label %204 + +85: ; preds = %82 + br i1 %7, label %205, label %206 + +86: ; preds = %82 + br i1 %7, label %207, label %208 + +87: ; preds = %80 + br i1 %6, label %89, label %90 + +88: ; preds = %80 + br i1 %6, label %91, label %92 + +89: ; preds = %87 + br i1 %7, label %209, label %210 + +90: ; preds = %87 + br i1 %7, label %211, label %212 + +91: ; preds = %88 + br i1 %7, label %213, label %214 + +92: ; preds = %88 + br i1 %7, label %215, label %216 + +93: ; preds = %78 + br i1 %5, label %95, label %96 + +94: ; preds = %78 + br i1 %5, label %101, label %102 + +95: ; preds = %93 + br i1 %6, label %97, label %98 + +96: ; preds = %93 + br i1 %6, label %99, label %100 + +97: ; preds = %95 + br i1 %7, label %217, label %218 + +98: ; preds = %95 + br i1 %7, label %219, label %220 + +99: ; preds = %96 + br i1 %7, label %221, label %222 + +100: ; preds = %96 + br i1 %7, label %223, label %224 + +101: ; preds = %94 + br i1 %6, label %103, label %104 + +102: ; preds = %94 + br i1 %6, label %105, label %106 + +103: ; preds = %101 + br i1 %7, label %225, label %226 + +104: ; preds = %101 + br i1 %7, label %227, label %228 + +105: ; preds = %102 + br i1 %7, label %229, label %230 + +106: ; preds = %102 + br i1 %7, label %231, label %232 + +107: ; preds = %16 + br i1 %4, label %109, label %110 + +108: ; preds = %16 + br i1 %4, label %123, label %124 + +109: ; preds = %107 + br i1 %5, label %111, label %112 + +110: ; preds = %107 + br i1 %5, label %117, label %118 + +111: ; preds = %109 + br i1 %6, label %113, label %114 + +112: ; preds = %109 + br i1 %6, label %115, label %116 + +113: ; preds = %111 + br i1 %7, label %233, label %234 + +114: ; preds = %111 + br i1 %7, label %235, label %236 + +115: ; preds = %112 + br i1 %7, label %237, label %238 + +116: ; preds = %112 + br i1 %7, label %239, label %240 + +117: ; preds = %110 + br i1 %6, label %119, label %120 + +118: ; preds = %110 + br i1 %6, label %121, label %122 + +119: ; preds = %117 + br i1 %7, label %241, label %242 + +120: ; preds = %117 + br i1 %7, label %243, label %244 + +121: ; preds = %118 + br i1 %7, label %245, label %246 + +122: ; preds = %118 + br i1 %7, label %247, label %248 + +123: ; preds = %108 + br i1 %5, label %125, label %126 + +124: ; preds = %108 + br i1 %5, label %131, label %132 + +125: ; preds = %123 + br i1 %6, label %127, label %128 + +126: ; preds = %123 + br i1 %6, label %129, label %130 + +127: ; preds = %125 + br i1 %7, label %249, label %250 + +128: ; preds = %125 + br i1 %7, label %251, label %252 + +129: ; preds = %126 + br i1 %7, label %253, label %254 + +130: ; preds = %126 + br i1 %7, label %255, label %256 + +131: ; preds = %124 + br i1 %6, label %133, label %134 + +132: ; preds = %124 + br i1 %6, label %135, label %136 + +133: ; preds = %131 + br i1 %7, label %257, label %258 + +134: ; preds = %131 + br i1 %7, label %259, label %260 + +135: ; preds = %132 + br i1 %7, label %261, label %262 + +136: ; preds = %132 + br i1 %7, label %263, label %264 + +137: ; preds = %23 + br i1 %0, label %265, label %266 + +138: ; preds = %23 + br i1 %0, label %267, label %268 + +139: ; preds = %24 + br i1 %0, label %269, label %270 + +140: ; preds = %24 + br i1 %0, label %271, label %272 + +141: ; preds = %25 + br i1 %0, label %273, label %274 + +142: ; preds = %25 + br i1 %0, label %275, label %276 + +143: ; preds = %26 + br i1 %0, label %277, label %278 + +144: ; preds = %26 + br i1 %0, label %279, label %280 + +145: ; preds = %29 + br i1 %0, label %281, label %282 + +146: ; preds = %29 + br i1 %0, label %283, label %284 + +147: ; preds = %30 + br i1 %0, label %285, label %286 + +148: ; preds = %30 + br i1 %0, label %287, label %288 + +149: ; preds = %31 + br i1 %0, label %289, label %290 + +150: ; preds = %31 + br i1 %0, label %291, label %292 + +151: ; preds = %32 + br i1 %0, label %293, label %294 + +152: ; preds = %32 + br i1 %0, label %295, label %296 + +153: ; preds = %37 + br i1 %0, label %297, label %298 + +154: ; preds = %37 + br i1 %0, label %299, label %300 + +155: ; preds = %38 + br i1 %0, label %301, label %302 + +156: ; preds = %38 + br i1 %0, label %303, label %304 + +157: ; preds = %39 + br i1 %0, label %305, label %306 + +158: ; preds = %39 + br i1 %0, label %307, label %308 + +159: ; preds = %40 + br i1 %0, label %309, label %310 + +160: ; preds = %40 + br i1 %0, label %311, label %312 + +161: ; preds = %43 + br i1 %0, label %313, label %314 + +162: ; preds = %43 + br i1 %0, label %315, label %316 + +163: ; preds = %44 + br i1 %0, label %317, label %318 + +164: ; preds = %44 + br i1 %0, label %319, label %320 + +165: ; preds = %45 + br i1 %0, label %321, label %322 + +166: ; preds = %45 + br i1 %0, label %323, label %324 + +167: ; preds = %46 + br i1 %0, label %325, label %326 + +168: ; preds = %46 + br i1 %0, label %327, label %328 + +169: ; preds = %53 + br i1 %0, label %329, label %330 + +170: ; preds = %53 + br i1 %0, label %331, label %332 + +171: ; preds = %54 + br i1 %0, label %333, label %334 + +172: ; preds = %54 + br i1 %0, label %335, label %336 + +173: ; preds = %55 + br i1 %0, label %337, label %338 + +174: ; preds = %55 + br i1 %0, label %339, label %340 + +175: ; preds = %56 + br i1 %0, label %341, label %342 + +176: ; preds = %56 + br i1 %0, label %343, label %344 + +177: ; preds = %59 + br i1 %0, label %345, label %346 + +178: ; preds = %59 + br i1 %0, label %347, label %348 + +179: ; preds = %60 + br i1 %0, label %349, label %350 + +180: ; preds = %60 + br i1 %0, label %351, label %352 + +181: ; preds = %61 + br i1 %0, label %353, label %354 + +182: ; preds = %61 + br i1 %0, label %355, label %356 + +183: ; preds = %62 + br i1 %0, label %357, label %358 + +184: ; preds = %62 + br i1 %0, label %359, label %360 + +185: ; preds = %67 + br i1 %0, label %361, label %362 + +186: ; preds = %67 + br i1 %0, label %363, label %364 + +187: ; preds = %68 + br i1 %0, label %365, label %366 + +188: ; preds = %68 + br i1 %0, label %367, label %368 + +189: ; preds = %69 + br i1 %0, label %369, label %370 + +190: ; preds = %69 + br i1 %0, label %371, label %372 + +191: ; preds = %70 + br i1 %0, label %373, label %374 + +192: ; preds = %70 + br i1 %0, label %375, label %376 + +193: ; preds = %73 + br i1 %0, label %377, label %378 + +194: ; preds = %73 + br i1 %0, label %379, label %380 + +195: ; preds = %74 + br i1 %0, label %381, label %382 + +196: ; preds = %74 + br i1 %0, label %383, label %384 + +197: ; preds = %75 + br i1 %0, label %385, label %386 + +198: ; preds = %75 + br i1 %0, label %387, label %388 + +199: ; preds = %76 + br i1 %0, label %389, label %390 + +200: ; preds = %76 + br i1 %0, label %391, label %392 + +201: ; preds = %83 + br i1 %0, label %393, label %394 + +202: ; preds = %83 + br i1 %0, label %395, label %396 + +203: ; preds = %84 + br i1 %0, label %397, label %398 + +204: ; preds = %84 + br i1 %0, label %399, label %400 + +205: ; preds = %85 + br i1 %0, label %401, label %402 + +206: ; preds = %85 + br i1 %0, label %403, label %404 + +207: ; preds = %86 + br i1 %0, label %405, label %406 + +208: ; preds = %86 + br i1 %0, label %407, label %408 + +209: ; preds = %89 + br i1 %0, label %409, label %410 + +210: ; preds = %89 + br i1 %0, label %411, label %412 + +211: ; preds = %90 + br i1 %0, label %413, label %414 + +212: ; preds = %90 + br i1 %0, label %415, label %416 + +213: ; preds = %91 + br i1 %0, label %417, label %418 + +214: ; preds = %91 + br i1 %0, label %419, label %420 + +215: ; preds = %92 + br i1 %0, label %421, label %422 + +216: ; preds = %92 + br i1 %0, label %423, label %424 + +217: ; preds = %97 + br i1 %0, label %425, label %426 + +218: ; preds = %97 + br i1 %0, label %427, label %428 + +219: ; preds = %98 + br i1 %0, label %429, label %430 + +220: ; preds = %98 + br i1 %0, label %431, label %432 + +221: ; preds = %99 + br i1 %0, label %433, label %434 + +222: ; preds = %99 + br i1 %0, label %435, label %436 + +223: ; preds = %100 + br i1 %0, label %437, label %438 + +224: ; preds = %100 + br i1 %0, label %439, label %440 + +225: ; preds = %103 + br i1 %0, label %441, label %442 + +226: ; preds = %103 + br i1 %0, label %443, label %444 + +227: ; preds = %104 + br i1 %0, label %445, label %446 + +228: ; preds = %104 + br i1 %0, label %447, label %448 + +229: ; preds = %105 + br i1 %0, label %449, label %450 + +230: ; preds = %105 + br i1 %0, label %451, label %452 + +231: ; preds = %106 + br i1 %0, label %453, label %454 + +232: ; preds = %106 + br i1 %0, label %455, label %456 + +233: ; preds = %113 + br i1 %0, label %457, label %458 + +234: ; preds = %113 + br i1 %0, label %459, label %460 + +235: ; preds = %114 + br i1 %0, label %461, label %462 + +236: ; preds = %114 + br i1 %0, label %463, label %464 + +237: ; preds = %115 + br i1 %0, label %465, label %466 + +238: ; preds = %115 + br i1 %0, label %467, label %468 + +239: ; preds = %116 + br i1 %0, label %469, label %470 + +240: ; preds = %116 + br i1 %0, label %471, label %472 + +241: ; preds = %119 + br i1 %0, label %473, label %474 + +242: ; preds = %119 + br i1 %0, label %475, label %476 + +243: ; preds = %120 + br i1 %0, label %477, label %478 + +244: ; preds = %120 + br i1 %0, label %479, label %480 + +245: ; preds = %121 + br i1 %0, label %481, label %482 + +246: ; preds = %121 + br i1 %0, label %483, label %484 + +247: ; preds = %122 + br i1 %0, label %485, label %486 + +248: ; preds = %122 + br i1 %0, label %487, label %488 + +249: ; preds = %127 + br i1 %0, label %489, label %490 + +250: ; preds = %127 + br i1 %0, label %491, label %492 + +251: ; preds = %128 + br i1 %0, label %493, label %494 + +252: ; preds = %128 + br i1 %0, label %495, label %496 + +253: ; preds = %129 + br i1 %0, label %497, label %498 + +254: ; preds = %129 + br i1 %0, label %499, label %500 + +255: ; preds = %130 + br i1 %0, label %501, label %502 + +256: ; preds = %130 + br i1 %0, label %503, label %504 + +257: ; preds = %133 + br i1 %0, label %505, label %506 + +258: ; preds = %133 + br i1 %0, label %507, label %508 + +259: ; preds = %134 + br i1 %0, label %509, label %510 + +260: ; preds = %134 + br i1 %0, label %511, label %512 + +261: ; preds = %135 + br i1 %0, label %513, label %514 + +262: ; preds = %135 + br i1 %0, label %515, label %516 + +263: ; preds = %136 + br i1 %0, label %517, label %518 + +264: ; preds = %136 + br i1 %0, label %519, label %520 + +265: ; preds = %137 + tail call void @putchar(i8 -1) + ret void + +266: ; preds = %137 + tail call void @putchar(i8 -3) + ret void + +267: ; preds = %138 + tail call void @putchar(i8 -5) + ret void + +268: ; preds = %138 + tail call void @putchar(i8 -7) + ret void + +269: ; preds = %139 + tail call void @putchar(i8 -9) + ret void + +270: ; preds = %139 + tail call void @putchar(i8 -11) + ret void + +271: ; preds = %140 + tail call void @putchar(i8 -13) + ret void + +272: ; preds = %140 + tail call void @putchar(i8 -15) + ret void + +273: ; preds = %141 + tail call void @putchar(i8 -17) + ret void + +274: ; preds = %141 + tail call void @putchar(i8 -19) + ret void + +275: ; preds = %142 + tail call void @putchar(i8 -21) + ret void + +276: ; preds = %142 + tail call void @putchar(i8 -23) + ret void + +277: ; preds = %143 + tail call void @putchar(i8 -25) + ret void + +278: ; preds = %143 + tail call void @putchar(i8 -27) + ret void + +279: ; preds = %144 + tail call void @putchar(i8 -29) + ret void + +280: ; preds = %144 + tail call void @putchar(i8 -31) + ret void + +281: ; preds = %145 + tail call void @putchar(i8 -33) + ret void + +282: ; preds = %145 + tail call void @putchar(i8 -35) + ret void + +283: ; preds = %146 + tail call void @putchar(i8 -37) + ret void + +284: ; preds = %146 + tail call void @putchar(i8 -39) + ret void + +285: ; preds = %147 + tail call void @putchar(i8 -41) + ret void + +286: ; preds = %147 + tail call void @putchar(i8 -43) + ret void + +287: ; preds = %148 + tail call void @putchar(i8 -45) + ret void + +288: ; preds = %148 + tail call void @putchar(i8 -47) + ret void + +289: ; preds = %149 + tail call void @putchar(i8 -49) + ret void + +290: ; preds = %149 + tail call void @putchar(i8 -51) + ret void + +291: ; preds = %150 + tail call void @putchar(i8 -53) + ret void + +292: ; preds = %150 + tail call void @putchar(i8 -55) + ret void + +293: ; preds = %151 + tail call void @putchar(i8 -57) + ret void + +294: ; preds = %151 + tail call void @putchar(i8 -59) + ret void + +295: ; preds = %152 + tail call void @putchar(i8 -61) + ret void + +296: ; preds = %152 + tail call void @putchar(i8 -63) + ret void + +297: ; preds = %153 + tail call void @putchar(i8 -65) + ret void + +298: ; preds = %153 + tail call void @putchar(i8 -67) + ret void + +299: ; preds = %154 + tail call void @putchar(i8 -69) + ret void + +300: ; preds = %154 + tail call void @putchar(i8 -71) + ret void + +301: ; preds = %155 + tail call void @putchar(i8 -73) + ret void + +302: ; preds = %155 + tail call void @putchar(i8 -75) + ret void + +303: ; preds = %156 + tail call void @putchar(i8 -77) + ret void + +304: ; preds = %156 + tail call void @putchar(i8 -79) + ret void + +305: ; preds = %157 + tail call void @putchar(i8 -81) + ret void + +306: ; preds = %157 + tail call void @putchar(i8 -83) + ret void + +307: ; preds = %158 + tail call void @putchar(i8 -85) + ret void + +308: ; preds = %158 + tail call void @putchar(i8 -87) + ret void + +309: ; preds = %159 + tail call void @putchar(i8 -89) + ret void + +310: ; preds = %159 + tail call void @putchar(i8 -91) + ret void + +311: ; preds = %160 + tail call void @putchar(i8 -93) + ret void + +312: ; preds = %160 + tail call void @putchar(i8 -95) + ret void + +313: ; preds = %161 + tail call void @putchar(i8 -97) + ret void + +314: ; preds = %161 + tail call void @putchar(i8 -99) + ret void + +315: ; preds = %162 + tail call void @putchar(i8 -101) + ret void + +316: ; preds = %162 + tail call void @putchar(i8 -103) + ret void + +317: ; preds = %163 + tail call void @putchar(i8 -105) + ret void + +318: ; preds = %163 + tail call void @putchar(i8 -107) + ret void + +319: ; preds = %164 + tail call void @putchar(i8 -109) + ret void + +320: ; preds = %164 + tail call void @putchar(i8 -111) + ret void + +321: ; preds = %165 + tail call void @putchar(i8 -113) + ret void + +322: ; preds = %165 + tail call void @putchar(i8 -115) + ret void + +323: ; preds = %166 + tail call void @putchar(i8 -117) + ret void + +324: ; preds = %166 + tail call void @putchar(i8 -119) + ret void + +325: ; preds = %167 + tail call void @putchar(i8 -121) + ret void + +326: ; preds = %167 + tail call void @putchar(i8 -123) + ret void + +327: ; preds = %168 + tail call void @putchar(i8 -125) + ret void + +328: ; preds = %168 + tail call void @putchar(i8 -127) + ret void + +329: ; preds = %169 + tail call void @putchar(i8 127) + ret void + +330: ; preds = %169 + tail call void @putchar(i8 125) + ret void + +331: ; preds = %170 + tail call void @putchar(i8 123) + ret void + +332: ; preds = %170 + tail call void @putchar(i8 121) + ret void + +333: ; preds = %171 + tail call void @putchar(i8 119) + ret void + +334: ; preds = %171 + tail call void @putchar(i8 117) + ret void + +335: ; preds = %172 + tail call void @putchar(i8 115) + ret void + +336: ; preds = %172 + tail call void @putchar(i8 113) + ret void + +337: ; preds = %173 + tail call void @putchar(i8 111) + ret void + +338: ; preds = %173 + tail call void @putchar(i8 109) + ret void + +339: ; preds = %174 + tail call void @putchar(i8 107) + ret void + +340: ; preds = %174 + tail call void @putchar(i8 105) + ret void + +341: ; preds = %175 + tail call void @putchar(i8 103) + ret void + +342: ; preds = %175 + tail call void @putchar(i8 101) + ret void + +343: ; preds = %176 + tail call void @putchar(i8 99) + ret void + +344: ; preds = %176 + tail call void @putchar(i8 97) + ret void + +345: ; preds = %177 + tail call void @putchar(i8 95) + ret void + +346: ; preds = %177 + tail call void @putchar(i8 93) + ret void + +347: ; preds = %178 + tail call void @putchar(i8 91) + ret void + +348: ; preds = %178 + tail call void @putchar(i8 89) + ret void + +349: ; preds = %179 + tail call void @putchar(i8 87) + ret void + +350: ; preds = %179 + tail call void @putchar(i8 85) + ret void + +351: ; preds = %180 + tail call void @putchar(i8 83) + ret void + +352: ; preds = %180 + tail call void @putchar(i8 81) + ret void + +353: ; preds = %181 + tail call void @putchar(i8 79) + ret void + +354: ; preds = %181 + tail call void @putchar(i8 77) + ret void + +355: ; preds = %182 + tail call void @putchar(i8 75) + ret void + +356: ; preds = %182 + tail call void @putchar(i8 73) + ret void + +357: ; preds = %183 + tail call void @putchar(i8 71) + ret void + +358: ; preds = %183 + tail call void @putchar(i8 69) + ret void + +359: ; preds = %184 + tail call void @putchar(i8 67) + ret void + +360: ; preds = %184 + tail call void @putchar(i8 65) + ret void + +361: ; preds = %185 + tail call void @putchar(i8 63) + ret void + +362: ; preds = %185 + tail call void @putchar(i8 61) + ret void + +363: ; preds = %186 + tail call void @putchar(i8 59) + ret void + +364: ; preds = %186 + tail call void @putchar(i8 57) + ret void + +365: ; preds = %187 + tail call void @putchar(i8 55) + ret void + +366: ; preds = %187 + tail call void @putchar(i8 53) + ret void + +367: ; preds = %188 + tail call void @putchar(i8 51) + ret void + +368: ; preds = %188 + tail call void @putchar(i8 49) + ret void + +369: ; preds = %189 + tail call void @putchar(i8 47) + ret void + +370: ; preds = %189 + tail call void @putchar(i8 45) + ret void + +371: ; preds = %190 + tail call void @putchar(i8 43) + ret void + +372: ; preds = %190 + tail call void @putchar(i8 41) + ret void + +373: ; preds = %191 + tail call void @putchar(i8 39) + ret void + +374: ; preds = %191 + tail call void @putchar(i8 37) + ret void + +375: ; preds = %192 + tail call void @putchar(i8 35) + ret void + +376: ; preds = %192 + tail call void @putchar(i8 33) + ret void + +377: ; preds = %193 + tail call void @putchar(i8 31) + ret void + +378: ; preds = %193 + tail call void @putchar(i8 29) + ret void + +379: ; preds = %194 + tail call void @putchar(i8 27) + ret void + +380: ; preds = %194 + tail call void @putchar(i8 25) + ret void + +381: ; preds = %195 + tail call void @putchar(i8 23) + ret void + +382: ; preds = %195 + tail call void @putchar(i8 21) + ret void + +383: ; preds = %196 + tail call void @putchar(i8 19) + ret void + +384: ; preds = %196 + tail call void @putchar(i8 17) + ret void + +385: ; preds = %197 + tail call void @putchar(i8 15) + ret void + +386: ; preds = %197 + tail call void @putchar(i8 13) + ret void + +387: ; preds = %198 + tail call void @putchar(i8 11) + ret void + +388: ; preds = %198 + tail call void @putchar(i8 9) + ret void + +389: ; preds = %199 + tail call void @putchar(i8 7) + ret void + +390: ; preds = %199 + tail call void @putchar(i8 5) + ret void + +391: ; preds = %200 + tail call void @putchar(i8 3) + ret void + +392: ; preds = %200 + tail call void @putchar(i8 1) + ret void + +393: ; preds = %201 + tail call void @putchar(i8 -2) + ret void + +394: ; preds = %201 + tail call void @putchar(i8 -4) + ret void + +395: ; preds = %202 + tail call void @putchar(i8 -6) + ret void + +396: ; preds = %202 + tail call void @putchar(i8 -8) + ret void + +397: ; preds = %203 + tail call void @putchar(i8 -10) + ret void + +398: ; preds = %203 + tail call void @putchar(i8 -12) + ret void + +399: ; preds = %204 + tail call void @putchar(i8 -14) + ret void + +400: ; preds = %204 + tail call void @putchar(i8 -16) + ret void + +401: ; preds = %205 + tail call void @putchar(i8 -18) + ret void + +402: ; preds = %205 + tail call void @putchar(i8 -20) + ret void + +403: ; preds = %206 + tail call void @putchar(i8 -22) + ret void + +404: ; preds = %206 + tail call void @putchar(i8 -24) + ret void + +405: ; preds = %207 + tail call void @putchar(i8 -26) + ret void + +406: ; preds = %207 + tail call void @putchar(i8 -28) + ret void + +407: ; preds = %208 + tail call void @putchar(i8 -30) + ret void + +408: ; preds = %208 + tail call void @putchar(i8 -32) + ret void + +409: ; preds = %209 + tail call void @putchar(i8 -34) + ret void + +410: ; preds = %209 + tail call void @putchar(i8 -36) + ret void + +411: ; preds = %210 + tail call void @putchar(i8 -38) + ret void + +412: ; preds = %210 + tail call void @putchar(i8 -40) + ret void + +413: ; preds = %211 + tail call void @putchar(i8 -42) + ret void + +414: ; preds = %211 + tail call void @putchar(i8 -44) + ret void + +415: ; preds = %212 + tail call void @putchar(i8 -46) + ret void + +416: ; preds = %212 + tail call void @putchar(i8 -48) + ret void + +417: ; preds = %213 + tail call void @putchar(i8 -50) + ret void + +418: ; preds = %213 + tail call void @putchar(i8 -52) + ret void + +419: ; preds = %214 + tail call void @putchar(i8 -54) + ret void + +420: ; preds = %214 + tail call void @putchar(i8 -56) + ret void + +421: ; preds = %215 + tail call void @putchar(i8 -58) + ret void + +422: ; preds = %215 + tail call void @putchar(i8 -60) + ret void + +423: ; preds = %216 + tail call void @putchar(i8 -62) + ret void + +424: ; preds = %216 + tail call void @putchar(i8 -64) + ret void + +425: ; preds = %217 + tail call void @putchar(i8 -66) + ret void + +426: ; preds = %217 + tail call void @putchar(i8 -68) + ret void + +427: ; preds = %218 + tail call void @putchar(i8 -70) + ret void + +428: ; preds = %218 + tail call void @putchar(i8 -72) + ret void + +429: ; preds = %219 + tail call void @putchar(i8 -74) + ret void + +430: ; preds = %219 + tail call void @putchar(i8 -76) + ret void + +431: ; preds = %220 + tail call void @putchar(i8 -78) + ret void + +432: ; preds = %220 + tail call void @putchar(i8 -80) + ret void + +433: ; preds = %221 + tail call void @putchar(i8 -82) + ret void + +434: ; preds = %221 + tail call void @putchar(i8 -84) + ret void + +435: ; preds = %222 + tail call void @putchar(i8 -86) + ret void + +436: ; preds = %222 + tail call void @putchar(i8 -88) + ret void + +437: ; preds = %223 + tail call void @putchar(i8 -90) + ret void + +438: ; preds = %223 + tail call void @putchar(i8 -92) + ret void + +439: ; preds = %224 + tail call void @putchar(i8 -94) + ret void + +440: ; preds = %224 + tail call void @putchar(i8 -96) + ret void + +441: ; preds = %225 + tail call void @putchar(i8 -98) + ret void + +442: ; preds = %225 + tail call void @putchar(i8 -100) + ret void + +443: ; preds = %226 + tail call void @putchar(i8 -102) + ret void + +444: ; preds = %226 + tail call void @putchar(i8 -104) + ret void + +445: ; preds = %227 + tail call void @putchar(i8 -106) + ret void + +446: ; preds = %227 + tail call void @putchar(i8 -108) + ret void + +447: ; preds = %228 + tail call void @putchar(i8 -110) + ret void + +448: ; preds = %228 + tail call void @putchar(i8 -112) + ret void + +449: ; preds = %229 + tail call void @putchar(i8 -114) + ret void + +450: ; preds = %229 + tail call void @putchar(i8 -116) + ret void + +451: ; preds = %230 + tail call void @putchar(i8 -118) + ret void + +452: ; preds = %230 + tail call void @putchar(i8 -120) + ret void + +453: ; preds = %231 + tail call void @putchar(i8 -122) + ret void + +454: ; preds = %231 + tail call void @putchar(i8 -124) + ret void + +455: ; preds = %232 + tail call void @putchar(i8 -126) + ret void + +456: ; preds = %232 + tail call void @putchar(i8 -128) + ret void + +457: ; preds = %233 + tail call void @putchar(i8 126) + ret void + +458: ; preds = %233 + tail call void @putchar(i8 124) + ret void + +459: ; preds = %234 + tail call void @putchar(i8 122) + ret void + +460: ; preds = %234 + tail call void @putchar(i8 120) + ret void + +461: ; preds = %235 + tail call void @putchar(i8 118) + ret void + +462: ; preds = %235 + tail call void @putchar(i8 116) + ret void + +463: ; preds = %236 + tail call void @putchar(i8 114) + ret void + +464: ; preds = %236 + tail call void @putchar(i8 112) + ret void + +465: ; preds = %237 + tail call void @putchar(i8 110) + ret void + +466: ; preds = %237 + tail call void @putchar(i8 108) + ret void + +467: ; preds = %238 + tail call void @putchar(i8 106) + ret void + +468: ; preds = %238 + tail call void @putchar(i8 104) + ret void + +469: ; preds = %239 + tail call void @putchar(i8 102) + ret void + +470: ; preds = %239 + tail call void @putchar(i8 100) + ret void + +471: ; preds = %240 + tail call void @putchar(i8 98) + ret void + +472: ; preds = %240 + tail call void @putchar(i8 96) + ret void + +473: ; preds = %241 + tail call void @putchar(i8 94) + ret void + +474: ; preds = %241 + tail call void @putchar(i8 92) + ret void + +475: ; preds = %242 + tail call void @putchar(i8 90) + ret void + +476: ; preds = %242 + tail call void @putchar(i8 88) + ret void + +477: ; preds = %243 + tail call void @putchar(i8 86) + ret void + +478: ; preds = %243 + tail call void @putchar(i8 84) + ret void + +479: ; preds = %244 + tail call void @putchar(i8 82) + ret void + +480: ; preds = %244 + tail call void @putchar(i8 80) + ret void + +481: ; preds = %245 + tail call void @putchar(i8 78) + ret void + +482: ; preds = %245 + tail call void @putchar(i8 76) + ret void + +483: ; preds = %246 + tail call void @putchar(i8 74) + ret void + +484: ; preds = %246 + tail call void @putchar(i8 72) + ret void + +485: ; preds = %247 + tail call void @putchar(i8 70) + ret void + +486: ; preds = %247 + tail call void @putchar(i8 68) + ret void + +487: ; preds = %248 + tail call void @putchar(i8 66) + ret void + +488: ; preds = %248 + tail call void @putchar(i8 64) + ret void + +489: ; preds = %249 + tail call void @putchar(i8 62) + ret void + +490: ; preds = %249 + tail call void @putchar(i8 60) + ret void + +491: ; preds = %250 + tail call void @putchar(i8 58) + ret void + +492: ; preds = %250 + tail call void @putchar(i8 56) + ret void + +493: ; preds = %251 + tail call void @putchar(i8 54) + ret void + +494: ; preds = %251 + tail call void @putchar(i8 52) + ret void + +495: ; preds = %252 + tail call void @putchar(i8 50) + ret void + +496: ; preds = %252 + tail call void @putchar(i8 48) + ret void + +497: ; preds = %253 + tail call void @putchar(i8 46) + ret void + +498: ; preds = %253 + tail call void @putchar(i8 44) + ret void + +499: ; preds = %254 + tail call void @putchar(i8 42) + ret void + +500: ; preds = %254 + tail call void @putchar(i8 40) + ret void + +501: ; preds = %255 + tail call void @putchar(i8 38) + ret void + +502: ; preds = %255 + tail call void @putchar(i8 36) + ret void + +503: ; preds = %256 + tail call void @putchar(i8 34) + ret void + +504: ; preds = %256 + tail call void @putchar(i8 32) + ret void + +505: ; preds = %257 + tail call void @putchar(i8 30) + ret void + +506: ; preds = %257 + tail call void @putchar(i8 28) + ret void + +507: ; preds = %258 + tail call void @putchar(i8 26) + ret void + +508: ; preds = %258 + tail call void @putchar(i8 24) + ret void + +509: ; preds = %259 + tail call void @putchar(i8 22) + ret void + +510: ; preds = %259 + tail call void @putchar(i8 20) + ret void + +511: ; preds = %260 + tail call void @putchar(i8 18) + ret void + +512: ; preds = %260 + tail call void @putchar(i8 16) + ret void + +513: ; preds = %261 + tail call void @putchar(i8 14) + ret void + +514: ; preds = %261 + tail call void @putchar(i8 12) + ret void + +515: ; preds = %262 + tail call void @putchar(i8 10) + ret void + +516: ; preds = %262 + tail call void @putchar(i8 8) + ret void + +517: ; preds = %263 + tail call void @putchar(i8 6) + ret void + +518: ; preds = %263 + tail call void @putchar(i8 4) + ret void + +519: ; preds = %264 + tail call void @putchar(i8 2) + ret void + +520: ; preds = %264 + tail call void @putchar(i8 0) + ret void +} + define void @main() local_unnamed_addr { %1 = tail call i8 @getchar() - tail call void @putchar(i8 %1) + %2 = icmp sgt i8 %1, -1 + %3 = and i8 %1, 64 + %4 = icmp eq i8 %3, 0 + %5 = and i8 %1, 32 + %6 = icmp eq i8 %5, 0 + br i1 %2, label %12, label %7 + +7: ; preds = %0 + br i1 %4, label %10, label %8 + +8: ; preds = %7 + br i1 %6, label %9, label %codeRepl.i.i + +codeRepl.i.i: ; preds = %8 + tail call fastcc void @__elem_2(i1 true, i8 %1, i1 true, i1 true) + br label %__elem_0.exit + +9: ; preds = %8 + tail call fastcc void @__elem_2(i1 false, i8 %1, i1 true, i1 true) + br label %__elem_0.exit + +10: ; preds = %7 + br i1 %6, label %11, label %codeRepl.i1.i + +codeRepl.i1.i: ; preds = %10 + tail call fastcc void @__elem_2(i1 true, i8 %1, i1 true, i1 false) + br label %__elem_0.exit + +11: ; preds = %10 + tail call fastcc void @__elem_2(i1 false, i8 %1, i1 true, i1 false) + br label %__elem_0.exit + +__elem_0.exit: ; preds = %codeRepl.i1.i3, %16, %codeRepl.i.i1, %14, %codeRepl.i1.i, %11, %codeRepl.i.i, %9 ret void + +12: ; preds = %0 + br i1 %4, label %15, label %13 + +13: ; preds = %12 + br i1 %6, label %14, label %codeRepl.i.i1 + +codeRepl.i.i1: ; preds = %13 + tail call fastcc void @__elem_2(i1 true, i8 %1, i1 false, i1 true) + br label %__elem_0.exit + +14: ; preds = %13 + tail call fastcc void @__elem_2(i1 false, i8 %1, i1 false, i1 true) + br label %__elem_0.exit + +15: ; preds = %12 + br i1 %6, label %16, label %codeRepl.i1.i3 + +codeRepl.i1.i3: ; preds = %15 + tail call fastcc void @__elem_2(i1 true, i8 %1, i1 false, i1 false) + br label %__elem_0.exit + +16: ; preds = %15 + tail call fastcc void @__elem_2(i1 false, i8 %1, i1 false, i1 false) + br label %__elem_0.exit } attributes #0 = { nofree nounwind } diff --git a/test/Golden/ForeignNames.opt.ll b/test/Golden/ForeignNames.opt.ll index 21d579c..dcf24ed 100644 --- a/test/Golden/ForeignNames.opt.ll +++ b/test/Golden/ForeignNames.opt.ll @@ -2,12 +2,12 @@ source_filename = "test/Golden/ForeignNames.elem" ; Function Attrs: norecurse nounwind readnone -define void @"\5C"() local_unnamed_addr #0 { +define void @"\09"() local_unnamed_addr #0 { ret void } ; Function Attrs: norecurse nounwind readnone -define void @"\22"() local_unnamed_addr #0 { +define void @"\0A"() local_unnamed_addr #0 { ret void } @@ -17,12 +17,12 @@ define void @"\0D"() local_unnamed_addr #0 { } ; Function Attrs: norecurse nounwind readnone -define void @"\0A"() local_unnamed_addr #0 { +define void @"\22"() local_unnamed_addr #0 { ret void } ; Function Attrs: norecurse nounwind readnone -define void @"\09"() local_unnamed_addr #0 { +define void @"\5C"() local_unnamed_addr #0 { ret void } diff --git a/test/Golden/FunctionInIO.opt.ll b/test/Golden/FunctionInIO.opt.ll index 990503b..5df40bb 100644 --- a/test/Golden/FunctionInIO.opt.ll +++ b/test/Golden/FunctionInIO.opt.ll @@ -10,10 +10,11 @@ define i1 @main(i1) local_unnamed_addr #0 { } define i1 @main2() local_unnamed_addr { +__elem_0.exit: + %0 = tail call i1 @getbit() %1 = tail call i1 @getbit() - %2 = tail call i1 @getbit() - %3 = xor i1 %1, %2 - ret i1 %3 + %2 = xor i1 %0, %1 + ret i1 %2 } attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/MemoryBit.opt.ll b/test/Golden/MemoryBit.opt.ll index 16b845f..83fd937 100644 --- a/test/Golden/MemoryBit.opt.ll +++ b/test/Golden/MemoryBit.opt.ll @@ -4,8 +4,14 @@ source_filename = "test/Golden/MemoryBit.elem" ; Function Attrs: nofree norecurse nounwind define void @main() local_unnamed_addr #0 { %1 = load volatile i1, i1* inttoptr (i14 -8192 to i1*), align 8192 - %not. = xor i1 %1, true - store volatile i1 %not., i1* inttoptr (i14 -8192 to i1*), align 8192 + br i1 %1, label %2, label %3 + +2: ; preds = %0 + store volatile i1 false, i1* inttoptr (i14 -8192 to i1*), align 8192 + ret void + +3: ; preds = %0 + store volatile i1 true, i1* inttoptr (i14 -8192 to i1*), align 8192 ret void } diff --git a/test/Golden/NestedBranch.opt.ll b/test/Golden/NestedBranch.opt.ll index 45110ef..3757558 100644 --- a/test/Golden/NestedBranch.opt.ll +++ b/test/Golden/NestedBranch.opt.ll @@ -5,12 +5,12 @@ declare void @dothing() local_unnamed_addr define void @main(i8) local_unnamed_addr { %2 = icmp eq i8 %0, 0 - br i1 %2, label %3, label %4 + br i1 %2, label %codeRepl.i, label %3 -3: ; preds = %1 - tail call void @dothing() - br label %4 - -4: ; preds = %3, %1 +3: ; preds = %codeRepl.i, %1 ret void + +codeRepl.i: ; preds = %1 + tail call void @dothing() + br label %3 } diff --git a/test/Golden/NestedBranch2.elem b/test/Golden/NestedBranch2.elem index c94001b..a2d1932 100644 --- a/test/Golden/NestedBranch2.elem +++ b/test/Golden/NestedBranch2.elem @@ -1,25 +1,36 @@ foreign export "main" main - : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + -- : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + -- : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + : (∀ 0 → 0 → 0) → IO (∀ 0 → 0) foreign import c_dothing "dothing" - : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + -- : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + -- : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + : (∀ 0 → 0 → 0) → IO (∀ 0 → 0) foreign primitive pureIO : ∀ 0 → IO 0 -foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 +-- foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 +{- main = abort_if_null (λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) bindIO @(∀ 0 → 0) (c_dothing 0) @(∀ 0 → 0) (λ(∀ 0 → 0) (c_dothing 1))) +-} +main = abort_if_null c_dothing -abort_if_null = λ((∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) → IO (∀ 0 → 0)) - λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) - 0 @(∀ 0 → 0 → 0) (λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) - or 0 (or 1 (or 2 3)) - ) @(IO (∀ 0 → 0)) (1 0) (pureIO @(∀ 0 → 0) (Λ λ0 0)) +-- abort_if_null = λ((∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) {- → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) -} → 0) → 0) → IO (∀ 0 → 0)) +-- λ(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) {- → (∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) -} → 0) → 0) +-- 0 @(∀ 0 → 0 → 0) (λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) -- λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) +-- -- or 0 (or 1 (or 2 3)) +-- or 0 1 +-- ) @(IO (∀ 0 → 0)) (1 0) (pureIO @(∀ 0 → 0) (Λ λ0 0)) +-- +-- or = λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) 1 @(∀ 0 → 0 → 0) t 0 +-- +-- t = Λ λ0 λ0 1 -or = λ(∀ 0 → 0 → 0) λ(∀ 0 → 0 → 0) 1 @(∀ 0 → 0 → 0) t 0 +abort_if_null = λ((∀ 0 → 0 → 0) → IO (∀ 0 → 0)) λ(∀ 0 → 0 → 0) 0 @(IO (∀ 0 → 0)) (1 0) (pureIO @(∀ 0 → 0) (Λ λ0 0)) -t = Λ λ0 λ0 1 diff --git a/test/Golden/NestedBranch2.opt.ll b/test/Golden/NestedBranch2.opt.ll index 70e08b3..1eac854 100644 --- a/test/Golden/NestedBranch2.opt.ll +++ b/test/Golden/NestedBranch2.opt.ll @@ -1,22 +1,15 @@ ; ModuleID = '' source_filename = "test/Golden/NestedBranch2.elem" -declare void @dothing(i4) local_unnamed_addr +declare void @dothing(i1) local_unnamed_addr -define private fastcc void @"7252"(i4) unnamed_addr { - tail call void @dothing(i4 %0) - tail call void @dothing(i4 %0) - ret void -} +define void @main(i1) local_unnamed_addr { + br i1 %0, label %2, label %3 -define void @main(i4) local_unnamed_addr { - %2 = icmp eq i4 %0, 0 - br i1 %2, label %3, label %.sink.split - -.sink.split: ; preds = %1 - tail call fastcc void @"7252"(i4 %0) - br label %3 +2: ; preds = %1 + tail call void @dothing(i1 true) + ret void -3: ; preds = %1, %.sink.split +3: ; preds = %1 ret void } diff --git a/test/Golden/NestedBranch3.opt.ll b/test/Golden/NestedBranch3.opt.ll index f94df3c..4344e1d 100644 --- a/test/Golden/NestedBranch3.opt.ll +++ b/test/Golden/NestedBranch3.opt.ll @@ -3,20 +3,17 @@ source_filename = "test/Golden/NestedBranch3.elem" declare i2 @dothing() local_unnamed_addr -define private fastcc void @"2938"() unnamed_addr { - %1 = tail call i2 @dothing() - ret void -} - define i1 @main() local_unnamed_addr { %1 = tail call i2 @dothing() %2 = icmp eq i2 %1, 0 - br i1 %2, label %3, label %.sink.split + br i1 %2, label %__elem_0.exit, label %__elem_0.exit.sink.split -.sink.split: ; preds = %0 - tail call fastcc void @"2938"() - br label %3 +__elem_0.exit.sink.split: ; preds = %0 + %3 = tail call i2 @dothing() + %4 = icmp ne i2 %3, 0 + br label %__elem_0.exit -3: ; preds = %0, %.sink.split - ret i1 false +__elem_0.exit: ; preds = %0, %__elem_0.exit.sink.split + %5 = phi i1 [ %4, %__elem_0.exit.sink.split ], [ false, %0 ] + ret i1 %5 } diff --git a/test/Golden/ShareBindCont.opt.ll b/test/Golden/ShareBindCont.opt.ll index 5911f9a..1c68674 100644 --- a/test/Golden/ShareBindCont.opt.ll +++ b/test/Golden/ShareBindCont.opt.ll @@ -10,6 +10,6 @@ define i1 @main1() local_unnamed_addr { define i1 @main2() local_unnamed_addr { %1 = tail call i1 @getbit() - %not. = xor i1 %1, true - ret i1 %not. + %not.1.i = xor i1 %1, true + ret i1 %not.1.i } diff --git a/test/Golden/ShareIO.opt.ll b/test/Golden/ShareIO.opt.ll index e90fe07..d0ba9be 100644 --- a/test/Golden/ShareIO.opt.ll +++ b/test/Golden/ShareIO.opt.ll @@ -5,28 +5,20 @@ declare void @putbit(i1) local_unnamed_addr declare i1 @getbit() local_unnamed_addr -define private fastcc { i1, i1 } @"2564"() unnamed_addr { - %1 = tail call i1 @getbit() - %2 = tail call i1 @getbit() - %3 = insertvalue { i1, i1 } zeroinitializer, i1 %2, 1 - %4 = insertvalue { i1, i1 } %3, i1 %1, 0 - ret { i1, i1 } %4 -} - define void @main1() local_unnamed_addr { - %1 = tail call fastcc { i1, i1 } @"2564"() - %2 = extractvalue { i1, i1 } %1, 1 - %3 = extractvalue { i1, i1 } %1, 0 - %4 = xor i1 %3, %2 - tail call void @putbit(i1 %4) +__elem_0.exit: + %0 = tail call i1 @getbit() + %1 = tail call i1 @getbit() + %.sink = xor i1 %0, %1 + tail call void @putbit(i1 %.sink) ret void } define void @main2() local_unnamed_addr { - %1 = tail call fastcc { i1, i1 } @"2564"() - %2 = extractvalue { i1, i1 } %1, 1 - %3 = extractvalue { i1, i1 } %1, 0 - %4 = xor i1 %3, %2 - tail call void @putbit(i1 %4) +__elem_0.exit: + %0 = tail call i1 @getbit() + %1 = tail call i1 @getbit() + %.sink = xor i1 %0, %1 + tail call void @putbit(i1 %.sink) ret void } diff --git a/test/Golden/ShareIOPoly.elem b/test/Golden/ShareIOPoly.elem new file mode 100644 index 0000000..b54ce80 --- /dev/null +++ b/test/Golden/ShareIOPoly.elem @@ -0,0 +1,17 @@ +-- Verifies that polymorphic functions are shared correctly. + +foreign export "main1" main1 : (∀ 0 → 0 → 0) → IO (∀ 0 → 0 → 0) +foreign export "main2" main2 : (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) → IO (∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + +foreign import c_dothing "dothing" : IO (∀ 0 → 0) + +foreign primitive pureIO : ∀ 0 → IO 0 +foreign primitive bindIO : ∀ IO 0 → ∀ (1 → IO 0) → IO 0 + +main1 = shared @(∀ 0 → 0 → 0) +main2 = shared @(∀ ((∀ 0 → 0 → 0) → (∀ 0 → 0 → 0) → 0) → 0) + +shared = Λ λ0 bindIO + @(∀ 0 → 0) c_dothing + @0 (λ(∀ 0 → 0) pureIO @0 1) + diff --git a/test/Golden/ShareIOPoly.opt.ll b/test/Golden/ShareIOPoly.opt.ll new file mode 100644 index 0000000..2c0d633 --- /dev/null +++ b/test/Golden/ShareIOPoly.opt.ll @@ -0,0 +1,19 @@ +; ModuleID = '' +source_filename = "test/Golden/ShareIOPoly.elem" + +declare void @dothing() local_unnamed_addr + +define i1 @main1(i1 returned) local_unnamed_addr { + tail call void @dothing() + ret i1 %0 +} + +define i2 @main2(i2) local_unnamed_addr { +__elem_1.exit: + %1 = icmp sgt i2 %0, -1 + %2 = and i2 %0, 1 + tail call void @dothing() + %3 = or i2 %0, -2 + %4 = select i1 %1, i2 %2, i2 %3 + ret i2 %4 +} diff --git a/test/Main.hs b/test/Main.hs index a552516..d88162f 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -27,6 +27,5 @@ tests = do ] where timeout :: Timeout - -- timeout = mkTimeout 5000000 -- 5s - timeout = mkTimeout $ 7 * 86400 * 1000000 -- 7d + timeout = mkTimeout 120000000 -- 120s From 17712e896476cf6ec4ec422fcf8f0204c6a3a3d8 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Fri, 24 Jun 2022 13:11:21 +0100 Subject: [PATCH 09/17] Share operands --- src/Language/Elemental/Emit.hs | 16 +- src/Language/Elemental/InteractionNet.hs | 508 +++- test/Golden.hs | 44 +- test/Golden/Arithmetic.opt.ll | 11 +- test/Golden/BitOrder.opt.ll | 14 +- test/Golden/CallOrder.opt.ll | 54 +- test/Golden/EchoChar.opt.ll | 2752 +++++++--------------- test/Golden/ShareBindCont.opt.ll | 12 +- test/Golden/ShareIO.opt.ll | 4 +- test/Main.hs | 2 +- 10 files changed, 1327 insertions(+), 2090 deletions(-) diff --git a/src/Language/Elemental/Emit.hs b/src/Language/Elemental/Emit.hs index 92b84a8..8139084 100644 --- a/src/Language/Elemental/Emit.hs +++ b/src/Language/Elemental/Emit.hs @@ -96,12 +96,16 @@ emitDecl scopeTypes scope rr = \case bname = backendForeignName fname rn1 <- newNode $ ExternalRootNode bname bargs bret () rn2 <- newNode $ AccumIONode mempty () () - rn3 <- newNode $ Bind0FNode () () + rn3 <- newNode $ Bind0CNode () () rn4 <- newNode $ AppNode () () () + rn5 <- newNode $ LamNode () () () + rn6 <- newNode $ ReturnCNode () () linkNodes (Ref rn1 0) (Ref rn2 1) linkNodes (Ref rn2 0) (Ref rn4 2) linkNodes (Ref rn3 1) (Ref rn4 0) - mkLambda (Ref rn4 1) ReturnNode + linkNodes (Ref rn4 1) (Ref rn5 0) + linkNodes (Ref rn5 1) (Ref rn6 1) + linkNodes (Ref rn5 2) (Ref rn6 0) emitExpr scope (Ref rn3 0) $ applyArgs ltret ltargs ops $ wrapExport SZero scopeTypes t expr pure mempty @@ -173,7 +177,7 @@ emitExpr scope rr = \case linkNodes rr $ Ref rn1 0 BackendIO _ instr -> propagate1 rr $ IOContNode instr BackendPIO _ _ pio - -> mkLambda rr $ IOPNode (Backend.Partial (SSucc SZero) pio) + -> propagate1 rr $ IOANode (Backend.Partial (SSucc SZero) pio) PureIO -> do rn1 <- newNode $ LamNode () () () rn2 <- newNode $ IOPureNode () () @@ -202,16 +206,16 @@ emitExpr scope rr = \case let callp = Backend.Partial len $ withVarargs len $ Backend.Call (backendType tret) (Backend.ExternalName fname) len = sLength ltargs - mkLambda rr $ IOPNode callp + propagate1 rr $ IOANode callp IsolateBit bidx ssize -> do let opp = Backend.Partial (SSucc SZero) $ mkIsolateBit size bidx' size = fromIntegral $ toNatural ssize bidx' = fromIntegral $ toNatural bidx - mkLambda rr $ OperandPNode opp + propagate1 rr $ OperandANode opp InsertBit ssize -> do let opp = Backend.Partial (SSucc $ SSucc SZero) $ Backend.InsertBit size size = fromIntegral $ toNatural ssize - mkLambda rr $ OperandPNode opp + propagate1 rr $ OperandANode opp TestBit -> mkLambda rr Branch0Node where coerceScope :: SList (Const a) as -> SList (Const a) (IncrementAll 'Zero as) diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index f815760..02db5ff 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -183,27 +183,39 @@ data INetF a | AccumNBNode B.BlockList a a -- | i{n} | OperandNode B.Operand a + -- | {... ->} i{n} + | OperandANode (B.Partial B.Operand) a -- | (i{m}, {... ->} i{n}) | OperandPNode (B.Partial B.Operand) a a -- | B | IONode B.BlockList a + -- | {... ->} IO i{n} + | IOANode (B.Partial B.Instruction) a -- | (i{m}, {... ->} IO i{n}) | IOPNode (B.Partial B.Instruction) a a -- | (IO a, (a -> B) -> B) | IOPureNode a a -- | IO a | IOContNode B.Instruction a + -- | (B, i{n}) + | ReturnCNode a a -- | (i{n}, B) - | ReturnNode a a + | ReturnFNode a a -- | (IO a, (a -> IO b) -> IO b) | Bind0BNode a a -- | (IO a, (a -> B) -> B) - | Bind0FNode a a + | Bind0CNode a a + -- | (IO a, (a -> B) -> B) + | Bind0FNode B.Name a a + -- | (B, IO a, (a -> B) -> B) + | Bind1CNode a a a -- | (B, B) | Bind1FNode (B.Named B.Instruction) a a -- | (i1, IO (a -> a -> a)) | Branch0Node a a - -- | (i1, B, B, B) + -- | (B, i{n}, B, B) + | Branch0CNode a a a a + -- | (i{n}, B, B, B) | Branch0FNode a a a a -- | (B, B, B) | Branch1Node B.Operand a a a @@ -215,18 +227,22 @@ data INetF a | Merge0Node a a a -- | (NB, NB) | Merge1Node B.NamedBlockList a a - -- | (B, T, T, B) or (T, T, T, T) - | TBuildNode Level B.Name B.Name a a a a + -- | (a, T, T, a) + | TBuildNode Level BuildType B.Name a a a a -- | (B, T) | TEntryNode B.Name B.Operand a a -- | (T, T, T) | TSplitNode a a a -- | T | TCloseNode a - -- | (T, B, B) - | TLeaveNode a a a + -- | (T, a, a) + | TLeaveNode BuildType a a a -- | (T, T, T, i1) | TMatchNode Level a a a a + -- | (a, i{n} -> a, i{n}) + | PArgumentNode a a a + -- | (a, a) + | PReduceNode a a deriving stock (Foldable, Functor, Traversable) instance Pretty a => Pretty (INetF a) where @@ -248,20 +264,29 @@ instance Pretty a => Pretty (INetF a) where = "AccumNB" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty bs) <> nest 4 (line <> pretty bs) pretty (OperandNode op r0) = "Operand" <+> pretty r0 <+> pretty op + pretty (OperandANode opp r0) = "OperandA" <+> pretty r0 <+> pretty opp pretty (OperandPNode opp r0 r1) = "OperandP" <+> pretty r0 <+> pretty r1 <+> pretty opp pretty (IONode bs r0) = "IO" <+> pretty r0 <> nest 4 (line <> pretty bs) + pretty (IOANode iop r0) = "IOA" <+> pretty r0 <+> pretty iop pretty (IOPNode iop r0 r1) = "IOP" <+> pretty r0 <+> pretty r1 <+> pretty iop pretty (IOPureNode r0 r1) = "IOPure" <+> pretty r0 <+> pretty r1 pretty (IOContNode instr r0) = "IOCont" <+> pretty r0 <> nest 4 (line <> pretty instr) - pretty (ReturnNode r0 r1) = "Return" <+> pretty r0 <+> pretty r1 + pretty (ReturnCNode r0 r1) = "ReturnC" <+> pretty r0 <+> pretty r1 + pretty (ReturnFNode r0 r1) = "ReturnF" <+> pretty r0 <+> pretty r1 pretty (Bind0BNode r0 r1) = "Bind0B" <+> pretty r0 <+> pretty r1 - pretty (Bind0FNode r0 r1) = "Bind0F" <+> pretty r0 <+> pretty r1 - pretty (Bind1FNode nbs r0 r1) - = "Bind1F" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty nbs) + pretty (Bind0CNode r0 r1) = "Bind0C" <+> pretty r0 <+> pretty r1 + pretty (Bind0FNode name r0 r1) + = "Bind0F" <+> pretty r0 <+> pretty r1 <+> pretty name + pretty (Bind1CNode r0 r1 r2) + = "Bind1C" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (Bind1FNode instr r0 r1) + = "Bind1F" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty instr) pretty (Branch0Node r0 r1) = "Branch0" <+> pretty r0 <+> pretty r1 + pretty (Branch0CNode r0 r1 r2 r3) + = "Branch0C" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 pretty (Branch0FNode r0 r1 r2 r3) = "Branch0F" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 pretty (Branch1Node opc r0 r1 r2) @@ -274,18 +299,21 @@ instance Pretty a => Pretty (INetF a) where = "Merge0" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (Merge1Node nbs r0 r1) = "Merge1" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty nbs) - pretty (TBuildNode lvl name namep r0 r1 r2 r3) = "TBuild" + pretty (TBuildNode lvl t namep r0 r1 r2 r3) = "TBuild" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 - <+> pretty name <+> pretty namep + <+> pretty t <+> pretty namep pretty (TEntryNode name opp r0 r1) = "TEntry" <+> pretty r0 <+> pretty r1 <+> pretty name <+> pretty opp pretty (TSplitNode r0 r1 r2) = "TSplit" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (TCloseNode r0) = "TClose" <+> pretty r0 - pretty (TLeaveNode r0 r1 r2) - = "TLeave" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (TLeaveNode t r0 r1 r2) + = "TLeave" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty t pretty (TMatchNode lvl r0 r1 r2 r3) = "TMatch" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 + pretty (PArgumentNode r0 r1 r2) + = "PArgument" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (PReduceNode r0 r1) = "PReduce" <+> pretty r0 <+> pretty r1 instance Ixed (INetF a) where ix idx f = indexing traverse $ Indexed go @@ -298,6 +326,13 @@ instance Ixed (INetF a) where type instance Index (INetF a) = Int type instance IxValue (INetF a) = a +data BuildType = BuildOperand | BuildIO + deriving stock (Eq, Ord, Show, Read) + +instance Pretty BuildType where + pretty BuildOperand = "Operand" + pretty BuildIO = "IO" + -- | Compiles an interaction net and a list of externals into a backend program. compileINet :: (HasRewriter sig m, Has TraceRewrite sig m) @@ -430,12 +465,45 @@ reduceNode n0@IONode {} n1@PrivateRootNode {} = reduceNode n1 n0 reduceNode (AccumIONode ib _ r0) (IONode bs _) = propagate1 r0 $ IONode $ B._entryBlock . B._blockInstrs %~ (B.unIBlock ib <>) $ bs reduceNode n0@IONode {} n1@AccumIONode {} = reduceNode n1 n0 +reduceNode (AccumIONode ib _ r0) (ReturnCNode _ r1) = do + rn2 <- newNode $ AccumIONode ib () () + rn3 <- newNode $ ReturnFNode () () + rn4 <- newNode $ PReduceNode () () + linkNodes (Ref rn2 0) (Ref rn3 1) + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes r0 $ Ref rn2 1 + linkNodes r1 $ Ref rn4 0 +reduceNode n0@ReturnCNode {} n1@AccumIONode {} = reduceNode n1 n0 +reduceNode (AccumIONode ib _ r0) (Bind1CNode _ r1 r2) = do + name <- newName + rn2 <- newNode $ AccumIONode ib () () + rn3 <- newNode $ Bind0FNode name () () + rn4 <- newNode $ AppNode () () () + rn5 <- newNode $ PReduceNode () () + linkNodes (Ref rn2 0) (Ref rn4 2) + linkNodes (Ref rn3 0) (Ref rn5 1) + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes r0 $ Ref rn2 1 + linkNodes r1 $ Ref rn5 0 + linkNodes r2 $ Ref rn4 1 +reduceNode n0@Bind1CNode {} n1@AccumIONode {} = reduceNode n1 n0 reduceNode (AccumIONode ib _ r0) (Bind1FNode instr _ r1) = do let ib' = B._IBlock %~ (`snoc` instr) $ ib rn2 <- newNode $ AccumIONode ib' () () linkNodes r0 $ Ref rn2 1 linkNodes r1 $ Ref rn2 0 reduceNode n0@Bind1FNode {} n1@AccumIONode {} = reduceNode n1 n0 +reduceNode (AccumIONode ib _ r0) (Branch0CNode _ r1 r2 r3) = do + rn4 <- newNode $ AccumIONode ib () () + rn5 <- newNode $ Branch0FNode () () () () + rn6 <- newNode $ PReduceNode () () + linkNodes (Ref rn4 0) (Ref rn5 3) + linkNodes (Ref rn5 0) (Ref rn6 1) + linkNodes r0 $ Ref rn4 1 + linkNodes r1 $ Ref rn6 0 + linkNodes r2 $ Ref rn5 1 + linkNodes r3 $ Ref rn5 2 +reduceNode n0@Branch0CNode {} n1@AccumIONode {} = reduceNode n1 n0 reduceNode (AccumIONode ib _ r0) (Branch1Node opc _ r1 r2) = do lblt <- newLabel lblf <- newLabel @@ -458,27 +526,46 @@ reduceNode n0@Branch1Node {} n1@AccumIONode {} = reduceNode n1 n0 reduceNode (AccumNBNode bs _ r0) (NamedBlockNode nbs _) = propagate1 r0 $ IONode $ B._namedBlocks %~ (<>) nbs $ bs reduceNode n0@NamedBlockNode {} n1@AccumNBNode {} = reduceNode n1 n0 +reduceNode (OperandANode opp _) (AppNode _ r0 r1) = do + rn2 <- newNode $ PArgumentNode () () () + propagate1 (Ref rn2 1) $ OperandANode opp + linkNodes r0 $ Ref rn2 2 + linkNodes r1 $ Ref rn2 0 +reduceNode n0@AppNode {} n1@OperandANode {} = reduceNode n1 n0 reduceNode (OperandPNode opp _ r0) (OperandNode op _) = case B.addOperand op opp of Left opp' -> mkLambda r0 $ OperandPNode opp' Right op' -> propagate1 r0 $ OperandNode op' reduceNode n0@OperandNode {} n1@OperandPNode {} = reduceNode n1 n0 +reduceNode (IOANode iop _) (AppNode _ r0 r1) = do + rn2 <- newNode $ PArgumentNode () () () + propagate1 (Ref rn2 1) $ IOANode iop + linkNodes r0 $ Ref rn2 2 + linkNodes r1 $ Ref rn2 0 +reduceNode n0@AppNode {} n1@IOANode {} = reduceNode n1 n0 reduceNode (IOPNode iop _ r0) (OperandNode op _) = case B.addOperand op iop of Left iop' -> mkLambda r0 $ IOPNode iop' Right instr -> propagate1 r0 $ IOContNode instr reduceNode n0@OperandNode {} n1@IOPNode {} = reduceNode n1 n0 -reduceNode (ReturnNode _ r0) (OperandNode op _) = propagate1 r0 +reduceNode (ReturnFNode _ r0) (OperandNode op _) = propagate1 r0 $ IONode $ B.BlockList (B.Block mempty $ B.Return op) mempty -reduceNode n0@OperandNode {} n1@ReturnNode {} = reduceNode n1 n0 +reduceNode n0@OperandNode {} n1@ReturnFNode {} = reduceNode n1 n0 reduceNode (Bind0BNode _ r0) (IOPureNode _ r1) = reassocPure r0 r1 reduceNode n0@IOPureNode {} n1@Bind0BNode {} = reduceNode n1 n0 -reduceNode (Bind0BNode _ r0) (IOContNode instr _) = reassocCont instr r0 +reduceNode (Bind0BNode _ r0) (IOContNode instr _) = do + rn1 <- newNode $ IOContNode instr () + reassocCont r0 $ Ref rn1 0 reduceNode n0@IOContNode {} n1@Bind0BNode {} = reduceNode n1 n0 -reduceNode (Bind0FNode _ r0) (IOPureNode _ r1) = linkNodes r0 r1 -reduceNode n0@IOPureNode {} n1@Bind0FNode {} = reduceNode n1 n0 -reduceNode (Bind0FNode _ r0) (IOContNode instr _) = do - name <- newName +reduceNode (Bind0BNode _ r0) (PArgumentNode _ r1 r2) = do + rn3 <- newNode $ PArgumentNode () () () + linkNodes r1 $ Ref rn3 1 + linkNodes r2 $ Ref rn3 2 + reassocCont r0 $ Ref rn3 0 +reduceNode n0@PArgumentNode {} n1@Bind0BNode {} = reduceNode n1 n0 +reduceNode (Bind0CNode _ r0) (IOPureNode _ r1) = linkNodes r0 r1 +reduceNode n0@IOPureNode {} n1@Bind0CNode {} = reduceNode n1 n0 +reduceNode (Bind0FNode name _ r0) (IOContNode instr _) = do let op = B.Reference (B.instrType instr) name rn2 <- newNode $ LamNode () () () rn3 <- newNode $ Bind1FNode (name B.:= instr) () () @@ -510,6 +597,30 @@ reduceNode (Branch0Node _ r0) (OperandNode op _) = do linkNodes r5 $ Ref rn3 1 linkNodes r6 $ Ref rn4 1 reduceNode n0@OperandNode {} n1@Branch0Node {} = reduceNode n1 n0 +reduceNode (Branch0Node _ r0) (PArgumentNode _ r1 r2) = do + rn1 <- newNode $ LamNode () () () + rn2 <- newNode $ DupNode 0 () () () + rn3 <- newNode $ AppNode () () () + rn4 <- newNode $ AppNode () () () + r5 <- mkChurchBool const + r6 <- mkChurchBool $ const id + rn7 <- newNode $ Branch0CNode () () () () + rn8 <- newNode $ PArgumentNode () () () + rn9 <- newNode $ IOPureNode () () + linkNodes (Ref rn1 0) (Ref rn9 1) + linkNodes (Ref rn1 1) (Ref rn2 0) + linkNodes (Ref rn1 2) (Ref rn7 0) + linkNodes (Ref rn2 1) (Ref rn3 0) + linkNodes (Ref rn2 2) (Ref rn4 0) + linkNodes (Ref rn3 2) (Ref rn7 2) + linkNodes (Ref rn4 2) (Ref rn7 3) + linkNodes (Ref rn7 1) (Ref rn8 0) + linkNodes r0 $ Ref rn9 0 + linkNodes r1 $ Ref rn8 1 + linkNodes r2 $ Ref rn8 2 + linkNodes r5 $ Ref rn3 1 + linkNodes r6 $ Ref rn4 1 +reduceNode n0@PArgumentNode {} n1@Branch0Node {} = reduceNode n1 n0 reduceNode (Branch0FNode _ r0 r1 r2) (OperandNode op _) = do rn3 <- newNode $ Branch1Node op () () () linkNodes r0 $ Ref rn3 1 @@ -528,12 +639,58 @@ reduceNode n0@NamedBlockNode {} n1@Merge0Node {} = reduceNode n1 n0 reduceNode (Merge1Node nbs0 _ r0) (NamedBlockNode nbs1 _) = propagate1 r0 $ NamedBlockNode $ nbs0 <> nbs1 reduceNode n0@NamedBlockNode {} n1@Merge1Node {} = reduceNode n1 n0 +reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (OperandNode op _) + = propagate2 r0 r1 TCloseNode *> propagate1 r2 (OperandNode op) +reduceNode n0@OperandNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (OperandANode opp _) + = propagate2 r0 r1 TCloseNode *> propagate1 r2 (OperandANode opp) +reduceNode n0@OperandANode {} n1@TBuildNode {} = reduceNode n1 n0 reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (IONode bs _) = do propagate2 r0 r1 TCloseNode propagate1 r2 $ IONode bs reduceNode n0@IONode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl name namep _ r0 r1 r2) (Bind1FNode instr _ r3) = do - rn4 <- newNode $ TBuildNode lvl name namep () () () () +reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (IOANode iop _) + = propagate2 r0 r1 TCloseNode *> propagate1 r2 (IOANode iop) +reduceNode n0@IOANode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (IOContNode instr _) + = propagate2 r0 r1 TCloseNode *> propagate1 r2 (IOContNode instr) +reduceNode n0@IOContNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (ReturnCNode _ r3) = do + rn4 <- newNode $ TBuildNode lvl BuildOperand namep () () () () + rn5 <- newNode $ ReturnFNode () () + rn6 <- newNode $ PReduceNode () () + linkNodes (Ref rn4 3) (Ref rn6 0) + linkNodes (Ref rn5 0) (Ref rn6 1) + linkNodes r0 $ Ref rn4 1 + linkNodes r1 $ Ref rn4 2 + linkNodes r2 $ Ref rn5 1 + linkNodes r3 $ Ref rn4 0 +reduceNode n0@ReturnCNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Bind1CNode _ r3 r4) = do + name <- newName + rn5 <- newNode $ TBuildNode lvl BuildOperand namep () () () () + rn6 <- newNode $ TBuildNode lvl BuildIO namep () () () () + rn7 <- newNode $ Bind0FNode name () () + rn8 <- newNode $ AppNode () () () + rn9 <- newNode $ TSplitNode () () () + rn10 <- newNode $ TSplitNode () () () + rn11 <- newNode $ PReduceNode () () + linkNodes (Ref rn5 1) (Ref rn9 1) + linkNodes (Ref rn5 2) (Ref rn10 1) + linkNodes (Ref rn5 3) (Ref rn11 0) + linkNodes (Ref rn6 1) (Ref rn9 2) + linkNodes (Ref rn6 2) (Ref rn10 2) + linkNodes (Ref rn6 0) (Ref rn8 2) + linkNodes (Ref rn7 0) (Ref rn11 1) + linkNodes (Ref rn7 1) (Ref rn8 0) + linkNodes r0 $ Ref rn9 0 + linkNodes r1 $ Ref rn10 0 + linkNodes r2 $ Ref rn6 3 + linkNodes r3 $ Ref rn5 0 + linkNodes r4 $ Ref rn8 1 +reduceNode n0@Bind1CNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Bind1FNode instr _ r3) = do + rn4 <- newNode $ TBuildNode lvl BuildIO namep () () () () rn5 <- newNode $ Bind1FNode instr () () linkNodes (Ref rn4 3) (Ref rn5 1) linkNodes r0 $ Ref rn4 1 @@ -541,28 +698,71 @@ reduceNode (TBuildNode lvl name namep _ r0 r1 r2) (Bind1FNode instr _ r3) = do linkNodes r2 $ Ref rn5 0 linkNodes r3 $ Ref rn4 0 reduceNode n0@Bind1FNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl name namep _ r0 r1 r2) (Branch1Node opc _ r3 r4) - = commute2a' (TBuildNode lvl name namep) TSplitNode TSplitNode +reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Branch0CNode _ r3 r4 r5) = do + rn6 <- newNode $ TBuildNode lvl BuildOperand namep () () () () + rn7 <- newNode $ TBuildNode lvl BuildIO namep () () () () + rn8 <- newNode $ TBuildNode lvl BuildIO namep () () () () + rn9 <- newNode $ Branch0CNode () () () () + rn10 <- newNode $ TSplitNode () () () + rn11 <- newNode $ TSplitNode () () () + rn12 <- newNode $ TSplitNode () () () + rn13 <- newNode $ TSplitNode () () () + linkNodes (Ref rn6 1) (Ref rn10 1) + linkNodes (Ref rn6 2) (Ref rn11 1) + linkNodes (Ref rn6 3) (Ref rn9 1) + linkNodes (Ref rn7 1) (Ref rn12 1) + linkNodes (Ref rn7 2) (Ref rn13 1) + linkNodes (Ref rn7 3) (Ref rn9 2) + linkNodes (Ref rn8 1) (Ref rn12 2) + linkNodes (Ref rn8 2) (Ref rn13 2) + linkNodes (Ref rn8 3) (Ref rn9 3) + linkNodes (Ref rn10 2) (Ref rn12 0) + linkNodes (Ref rn11 2) (Ref rn13 0) + linkNodes r0 $ Ref rn10 0 + linkNodes r1 $ Ref rn11 0 + linkNodes r2 $ Ref rn9 0 + linkNodes r3 $ Ref rn6 0 + linkNodes r4 $ Ref rn7 0 + linkNodes r5 $ Ref rn8 0 +reduceNode n0@Branch0CNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl t namep _ r0 r1 r2) (Branch1Node opc _ r3 r4) + = commute2a' (TBuildNode lvl t namep) TSplitNode TSplitNode (Branch1Node opc) r0 r1 r2 r3 r4 reduceNode n0@Branch1Node {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (PArgumentNode _ r3 r4) = do + rn5 <- newNode $ TBuildNode lvl BuildOperand namep () () () () + rn6 <- newNode $ TBuildNode lvl BuildOperand namep () () () () + rn7 <- newNode $ PArgumentNode () () () + rn8 <- newNode $ TSplitNode () () () + rn9 <- newNode $ TSplitNode () () () + linkNodes (Ref rn5 1) (Ref rn8 1) + linkNodes (Ref rn5 2) (Ref rn9 1) + linkNodes (Ref rn5 3) (Ref rn7 1) + linkNodes (Ref rn6 1) (Ref rn8 2) + linkNodes (Ref rn6 2) (Ref rn9 2) + linkNodes (Ref rn6 3) (Ref rn7 2) + linkNodes r0 $ Ref rn8 0 + linkNodes r1 $ Ref rn9 0 + linkNodes r2 $ Ref rn7 0 + linkNodes r3 $ Ref rn5 0 + linkNodes r4 $ Ref rn6 0 +reduceNode n0@PArgumentNode {} n1@TBuildNode {} = reduceNode n1 n0 reduceNode (AccumIONode ib _ r0) (TEntryNode name opp _ r1) = do let term = B.TailCall name opp propagate1 r0 $ IONode $ B.BlockList (B.Block (B.unIBlock ib) term) mempty propagate1 r1 TCloseNode reduceNode n0@TEntryNode {} n1@AccumIONode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl name0 namep _ r0 r1 r2) (TEntryNode name1 opp _ r3) - | name0 == name1 = error "reduceNode: found loop at TBuild/TEntry" - | otherwise = do - rn4 <- newNode $ TBuildNode lvl name0 namep () () () () - rn5 <- newNode $ TEntryNode name1 opp () () - linkNodes (Ref rn4 3) (Ref rn5 1) - linkNodes r0 $ Ref rn4 1 - linkNodes r1 $ Ref rn4 2 - linkNodes r2 $ Ref rn5 0 - linkNodes r3 $ Ref rn4 0 +reduceNode (TBuildNode lvl t namep _ r0 r1 r2) (TEntryNode name opp _ r3) = do + rn4 <- newNode $ TBuildNode lvl t namep () () () () + rn5 <- newNode $ TEntryNode name opp () () + linkNodes (Ref rn4 3) (Ref rn5 1) + linkNodes r0 $ Ref rn4 1 + linkNodes r1 $ Ref rn4 2 + linkNodes r2 $ Ref rn5 0 + linkNodes r3 $ Ref rn4 0 reduceNode n0@TEntryNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl name namep _ r0 r1 r2) (TSplitNode _ r3 r4) - = commute2a (TBuildNode lvl name namep) TSplitNode r0 r1 r2 r3 r4 +reduceNode (TBuildNode lvl t namep _ r0 r1 r2) (TSplitNode _ r3 r4) + = commute2a (TBuildNode lvl t namep) TSplitNode r0 r1 r2 r3 r4 reduceNode n0@TSplitNode {} n1@TBuildNode {} = reduceNode n1 n0 reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (TCloseNode _) = propagate3 r0 r1 r2 TCloseNode @@ -570,9 +770,9 @@ reduceNode n0@TCloseNode {} n1@TBuildNode {} = reduceNode n1 n0 reduceNode (TSplitNode _ r0 r1) (TCloseNode _) = propagate2 r0 r1 TCloseNode reduceNode n0@TCloseNode {} n1@TSplitNode {} = reduceNode n1 n0 reduceNode (TCloseNode _) (TCloseNode _) = pure () -reduceNode (TBuildNode lvl name namep _ r0 r1 r2) (TLeaveNode _ r3 r4) = do - rn5 <- newNode $ TBuildNode lvl name namep () () () () - rn6 <- newNode $ TLeaveNode () () () +reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (TLeaveNode t _ r3 r4) = do + rn5 <- newNode $ TBuildNode lvl t namep () () () () + rn6 <- newNode $ TLeaveNode t () () () linkNodes (Ref rn5 3) (Ref rn6 1) linkNodes r0 $ Ref rn5 1 linkNodes r1 $ Ref rn5 2 @@ -580,9 +780,9 @@ reduceNode (TBuildNode lvl name namep _ r0 r1 r2) (TLeaveNode _ r3 r4) = do linkNodes r3 $ Ref rn5 0 linkNodes r4 $ Ref rn6 2 reduceNode n0@TLeaveNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TLeaveNode _ r0 r1) (TCloseNode _) = linkNodes r0 r1 +reduceNode (TLeaveNode _ _ r0 r1) (TCloseNode _) = linkNodes r0 r1 reduceNode n0@TCloseNode {} n1@TLeaveNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl0 name namep _ r0 r1 r2) (TMatchNode lvl1 _ r3 r4 r5) +reduceNode (TBuildNode lvl0 t namep _ r0 r1 r2) (TMatchNode lvl1 _ r3 r4 r5) | lvl0 == lvl1 = do linkNodes r0 r3 linkNodes r1 r4 @@ -591,8 +791,8 @@ reduceNode (TBuildNode lvl0 name namep _ r0 r1 r2) (TMatchNode lvl1 _ r3 r4 r5) | otherwise = do let opp = B.Partial (SSucc $ SSucc SZero) $ mkSelect $ B.Reference (B.IntType 1) namep - rn6 <- newNode $ TBuildNode lvl0 name namep () () () () - rn7 <- newNode $ TBuildNode lvl0 name namep () () () () + rn6 <- newNode $ TBuildNode lvl0 t namep () () () () + rn7 <- newNode $ TBuildNode lvl0 t namep () () () () rn8 <- newNode $ TMatchNode lvl1 () () () () rn9 <- newNode $ TMatchNode lvl1 () () () () rn10 <- newNode $ OperandPNode opp () () @@ -613,6 +813,36 @@ reduceNode (TBuildNode lvl0 name namep _ r0 r1 r2) (TMatchNode lvl1 _ r3 r4 r5) linkNodes r4 $ Ref rn7 0 linkNodes r5 $ Ref rn11 2 reduceNode n0@TMatchNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (PArgumentNode _ r0 r1) (AppNode _ r2 r3) = do + rn4 <- newNode $ PArgumentNode () () () + rn5 <- newNode $ PArgumentNode () () () + linkNodes (Ref rn4 0) (Ref rn5 1) + linkNodes r0 $ Ref rn4 1 + linkNodes r1 $ Ref rn4 2 + linkNodes r2 $ Ref rn5 2 + linkNodes r3 $ Ref rn5 0 +reduceNode n0@AppNode {} n1@PArgumentNode {} = reduceNode n1 n0 +reduceNode (PArgumentNode _ r0 r1) (PReduceNode _ r2) = do + rn3 <- newNode $ AppNode () () () + rn4 <- newNode $ PReduceNode () () + rn5 <- newNode $ PReduceNode () () + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes (Ref rn3 1) (Ref rn5 1) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn5 0 + linkNodes r2 $ Ref rn3 2 +reduceNode n0@PReduceNode {} n1@PArgumentNode {} = reduceNode n1 n0 +reduceNode (PReduceNode _ r0) (OperandNode op _) + = propagate1 r0 $ OperandNode op +reduceNode n0@OperandNode {} n1@PReduceNode {} = reduceNode n1 n0 +reduceNode (PReduceNode _ r0) (OperandANode opp _) + = mkLambda r0 $ OperandPNode opp +reduceNode n0@OperandANode {} n1@PReduceNode {} = reduceNode n1 n0 +reduceNode (PReduceNode _ r0) (IOANode iop _) = mkLambda r0 $ IOPNode iop +reduceNode n0@IOANode {} n1@PReduceNode {} = reduceNode n1 n0 +reduceNode (PReduceNode _ r0) (IOContNode instr _) + = propagate1 r0 $ IOContNode instr +reduceNode n0@IOContNode {} n1@PReduceNode {} = reduceNode n1 n0 -- FFI Duplication reduceNode (DupNode _ _ r0 r1) (OperandNode op _) = propagate2 r0 r1 $ OperandNode op @@ -633,57 +863,71 @@ reduceNode n0@IOPureNode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode _ _ r0 r1) (IOContNode instr _) = propagate2 r0 r1 $ IOContNode instr reduceNode n0@IOContNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl _ r0 r1) (ReturnNode _ r2) - = commute1 (DupNode lvl) ReturnNode r0 r1 r2 -reduceNode n0@ReturnNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (ReturnCNode _ r2) = do + rn3 <- newNode $ ReturnCNode () () + linkNodes r2 $ Ref rn3 1 + dedupIO lvl r0 r1 $ Ref rn3 0 +reduceNode n0@ReturnCNode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (Bind0BNode _ r2) = commute1 (DupNode lvl) Bind0BNode r0 r1 r2 reduceNode n0@Bind0BNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl _ r0 r1) (Bind0FNode _ r2) - = commute1 (DupNode lvl) Bind0FNode r0 r1 r2 -reduceNode n0@Bind0FNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl _ r0 r1) (Bind1FNode b _ r2) - = do - rn3 <- newNode $ Bind1FNode b () () - linkNodes r2 $ Ref rn3 1 - dedupIO lvl r0 r1 $ Ref rn3 0 -reduceNode n0@Bind1FNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 _ r0 r1) (Branch0Node _ r2) - = commute1 (DupNode lvl0) Branch0Node r0 r1 r2 +reduceNode (DupNode lvl _ r0 r1) (Bind0CNode _ r2) + = commute1 (DupNode lvl) Bind0CNode r0 r1 r2 +reduceNode n0@Bind0CNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (Bind1CNode _ r2 r3) = do + rn4 <- newNode $ Bind1CNode () () () + linkNodes r2 $ Ref rn4 1 + linkNodes r3 $ Ref rn4 2 + dedupIO lvl r0 r1 $ Ref rn4 0 +reduceNode n0@Bind1CNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (Branch0Node _ r2) + = commute1 (DupNode lvl) Branch0Node r0 r1 r2 reduceNode n0@Branch0Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl _ r0 r1) (Branch1Node opc _ r2 r3) - = do +reduceNode (DupNode lvl _ r0 r1) (Branch0CNode _ r2 r3 r4) = do + rn5 <- newNode $ Branch0CNode () () () () + linkNodes r2 $ Ref rn5 1 + linkNodes r3 $ Ref rn5 2 + linkNodes r4 $ Ref rn5 3 + dedupIO lvl r0 r1 $ Ref rn5 0 +reduceNode n0@Branch0CNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (Branch1Node opc _ r2 r3) = do rn4 <- newNode $ Branch1Node opc () () () linkNodes r2 $ Ref rn4 1 linkNodes r3 $ Ref rn4 2 dedupIO lvl r0 r1 $ Ref rn4 0 reduceNode n0@Branch1Node {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 _ r0 r1) (TBuildNode lvl1 name namep _ r2 r3 r4) +reduceNode (DupNode lvl0 _ r0 r1) (TBuildNode lvl1 t namep _ r2 r3 r4) | lvl0 == lvl1 = do let opp = B.Reference (B.IntType 1) namep - rn5 <- newNode $ TLeaveNode () () () - rn6 <- newNode $ TLeaveNode () () () - rn7 <- newNode $ Branch1Node opp () () () - linkNodes (Ref rn5 2) (Ref rn7 1) - linkNodes (Ref rn6 2) (Ref rn7 2) + rn5 <- newNode $ TLeaveNode t () () () + rn6 <- newNode $ TLeaveNode t () () () linkNodes r0 $ Ref rn5 1 linkNodes r1 $ Ref rn6 1 linkNodes r2 $ Ref rn5 0 linkNodes r3 $ Ref rn6 0 - linkNodes r4 $ Ref rn7 0 + case t of + BuildOperand -> do + let opp' = B.Partial (SSucc $ SSucc SZero) $ mkSelect opp + rn7 <- newNode $ OperandPNode opp' () () + rn8 <- newNode $ AppNode () () () + linkNodes (Ref rn5 2) (Ref rn7 0) + linkNodes (Ref rn6 2) (Ref rn8 1) + linkNodes (Ref rn7 1) (Ref rn8 0) + linkNodes r4 $ Ref rn8 2 + BuildIO -> do + rn7 <- newNode $ Branch1Node opp () () () + linkNodes (Ref rn5 2) (Ref rn7 1) + linkNodes (Ref rn6 2) (Ref rn7 2) + linkNodes r4 $ Ref rn7 0 | otherwise = do let opp = B.Partial (SSucc $ SSucc SZero) $ mkSelect $ B.Reference (B.IntType 1) namep - rn2 <- newNode $ Branch0FNode () () () () rn3 <- newNode $ OperandPNode opp () () rn4 <- newNode $ AppNode () () () rn5 <- newNode $ TMatchNode lvl0 () () () () rn6 <- newNode $ TMatchNode lvl0 () () () () - rn7 <- newNode $ TBuildNode lvl1 name namep () () () () - rn8 <- newNode $ TBuildNode lvl1 name namep () () () () - linkNodes (Ref rn2 0) (Ref rn4 2) - linkNodes (Ref rn2 1) (Ref rn7 3) - linkNodes (Ref rn2 2) (Ref rn8 3) + rn7 <- newNode $ TBuildNode lvl1 t namep () () () () + rn8 <- newNode $ TBuildNode lvl1 t namep () () () () linkNodes (Ref rn3 0) (Ref rn5 3) linkNodes (Ref rn3 1) (Ref rn4 0) linkNodes (Ref rn4 1) (Ref rn6 3) @@ -695,7 +939,24 @@ reduceNode (DupNode lvl0 _ r0 r1) (TBuildNode lvl1 name namep _ r2 r3 r4) linkNodes r1 $ Ref rn8 0 linkNodes r2 $ Ref rn5 0 linkNodes r3 $ Ref rn6 0 - linkNodes r4 $ Ref rn2 3 + case t of + BuildOperand -> do + let opp' = B.Partial (SSucc $ SSucc $ SSucc SZero) mkSelect + rn2 <- newNode $ OperandPNode opp' () () + rn9 <- newNode $ AppNode () () () + rn10 <- newNode $ AppNode () () () + linkNodes (Ref rn2 0) (Ref rn4 2) + linkNodes (Ref rn2 1) (Ref rn9 0) + linkNodes (Ref rn7 3) (Ref rn9 1) + linkNodes (Ref rn8 3) (Ref rn10 1) + linkNodes (Ref rn9 2) (Ref rn10 0) + linkNodes r4 $ Ref rn10 2 + BuildIO -> do + rn2 <- newNode $ Branch0CNode () () () () + linkNodes (Ref rn2 1) (Ref rn4 2) + linkNodes (Ref rn2 2) (Ref rn7 3) + linkNodes (Ref rn2 3) (Ref rn8 3) + linkNodes r4 $ Ref rn2 0 reduceNode n0@TBuildNode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (TEntryNode name opp _ r2) = do rn3 <- newNode $ TEntryNode name opp () () @@ -720,8 +981,8 @@ reduceNode (IOContNode _ _) (DeadNode _) = pure () reduceNode n0@DeadNode {} n1@IOContNode {} = reduceNode n1 n0 reduceNode (Bind0BNode _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@Bind0BNode {} = reduceNode n1 n0 -reduceNode (Bind0FNode _ r0) (DeadNode _) = propagate1 r0 DeadNode -reduceNode n0@DeadNode {} n1@Bind0FNode {} = reduceNode n1 n0 +reduceNode (Bind0CNode _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@Bind0CNode {} = reduceNode n1 n0 reduceNode (Bind1FNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@Bind1FNode {} = reduceNode n1 n0 reduceNode (Branch0Node _ r0) (DeadNode _) = propagate1 r0 DeadNode @@ -743,15 +1004,18 @@ reduceNode (AccumIONode ib _ r0) (BoxNode _ _ r1) = do linkNodes r0 $ Ref rn2 1 linkNodes r1 $ Ref rn2 0 reduceNode n0@BoxNode {} n1@AccumIONode {} = reduceNode n1 n0 -reduceNode (OperandNode op _) (BoxNode _ _ r0) - = propagate1 r0 $ OperandNode op +reduceNode (OperandNode op _) (BoxNode _ _ r0) = propagate1 r0 $ OperandNode op reduceNode n0@BoxNode {} n1@OperandNode {} = reduceNode n1 n0 +reduceNode (OperandANode opp _) (BoxNode _ _ r0) + = propagate1 r0 $ OperandANode opp +reduceNode n0@BoxNode {} n1@OperandANode {} = reduceNode n1 n0 reduceNode (OperandPNode opp _ r0) (BoxNode lvl _ r1) = commute0 (OperandPNode opp) (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@OperandPNode {} = reduceNode n1 n0 -reduceNode (IONode b _) (BoxNode _ _ r0) - = propagate1 r0 $ IONode b +reduceNode (IONode b _) (BoxNode _ _ r0) = propagate1 r0 $ IONode b reduceNode n0@BoxNode {} n1@IONode {} = reduceNode n1 n0 +reduceNode (IOANode iop _) (BoxNode _ _ r0) = propagate1 r0 $ IOANode iop +reduceNode n0@BoxNode {} n1@IOANode {} = reduceNode n1 n0 reduceNode (IOPNode iop _ r0) (BoxNode lvl _ r1) = commute0 (IOPNode iop) (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@IOPNode {} = reduceNode n1 n0 @@ -761,21 +1025,33 @@ reduceNode n0@BoxNode {} n1@IOPureNode {} = reduceNode n1 n0 reduceNode (IOContNode instr _) (BoxNode _ _ r0) = propagate1 r0 $ IOContNode instr reduceNode n0@BoxNode {} n1@IOContNode {} = reduceNode n1 n0 -reduceNode (ReturnNode _ r0) (BoxNode lvl _ r1) - = commute0 ReturnNode (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@ReturnNode {} = reduceNode n1 n0 +reduceNode (ReturnCNode _ r0) (BoxNode lvl _ r1) + = commute0 ReturnCNode (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@ReturnCNode {} = reduceNode n1 n0 +reduceNode (ReturnFNode _ r0) (BoxNode lvl _ r1) + = commute0 ReturnFNode (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@ReturnFNode {} = reduceNode n1 n0 reduceNode (Bind0BNode _ r0) (BoxNode lvl _ r1) = commute0 Bind0BNode (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@Bind0BNode {} = reduceNode n1 n0 -reduceNode (Bind0FNode _ r0) (BoxNode lvl _ r1) - = commute0 Bind0FNode (BoxNode lvl) r0 r1 +reduceNode (Bind0CNode _ r0) (BoxNode lvl _ r1) + = commute0 Bind0CNode (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@Bind0CNode {} = reduceNode n1 n0 +reduceNode (Bind0FNode name _ r0) (BoxNode lvl _ r1) + = commute0 (Bind0FNode name) (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@Bind0FNode {} = reduceNode n1 n0 +reduceNode (Bind1CNode _ r0 r1) (BoxNode lvl _ r2) + = commute1 Bind1CNode (BoxNode lvl) r0 r1 r2 +reduceNode n0@BoxNode {} n1@Bind1CNode {} = reduceNode n1 n0 reduceNode (Bind1FNode nbs _ r0) (BoxNode lvl _ r1) = commute0 (Bind1FNode nbs) (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@Bind1FNode {} = reduceNode n1 n0 reduceNode (Branch0Node _ r0) (BoxNode lvl _ r1) = commute0 Branch0Node (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@Branch0Node {} = reduceNode n1 n0 +reduceNode (Branch0CNode _ r0 r1 r2) (BoxNode lvl _ r3) + = commute2b Branch0CNode (BoxNode lvl) r0 r1 r2 r3 +reduceNode n0@BoxNode {} n1@Branch0CNode {} = reduceNode n1 n0 reduceNode (Branch0FNode _ r0 r1 r2) (BoxNode lvl _ r3) = commute2b Branch0FNode (BoxNode lvl) r0 r1 r2 r3 reduceNode n0@BoxNode {} n1@Branch0FNode {} = reduceNode n1 n0 @@ -788,9 +1064,9 @@ reduceNode (LabelNode lbl _ r0) (BoxNode _ _ r1) linkNodes r0 $ Ref rn2 1 linkNodes r1 $ Ref rn2 0 reduceNode n0@BoxNode {} n1@LabelNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl0 name namep _ r0 r1 r2) (BoxNode lvl1 _ r3) +reduceNode (TBuildNode lvl0 t namep _ r0 r1 r2) (BoxNode lvl1 _ r3) = commute2b - (TBuildNode (if lvl0 < lvl1 then lvl0 else succ lvl0) name namep) + (TBuildNode (if lvl0 < lvl1 then lvl0 else succ lvl0) t namep) (BoxNode lvl1) r0 r1 r2 r3 reduceNode n0@BoxNode {} n1@TBuildNode {} = reduceNode n1 n0 @@ -802,14 +1078,20 @@ reduceNode (TSplitNode _ r0 r1) (BoxNode lvl _ r2) reduceNode n0@BoxNode {} n1@TSplitNode {} = reduceNode n1 n0 reduceNode (TCloseNode _) (BoxNode _ _ r0) = propagate1 r0 TCloseNode reduceNode n0@BoxNode {} n1@TCloseNode {} = reduceNode n1 n0 -reduceNode (TLeaveNode _ r0 r1) (BoxNode lvl _ r2) - = commute1 TLeaveNode (BoxNode lvl) r0 r1 r2 +reduceNode (TLeaveNode t _ r0 r1) (BoxNode lvl _ r2) + = commute1 (TLeaveNode t) (BoxNode lvl) r0 r1 r2 reduceNode n0@BoxNode {} n1@TLeaveNode {} = reduceNode n1 n0 reduceNode (TMatchNode lvl0 _ r0 r1 r2) (BoxNode lvl1 _ r3) = commute2b (TMatchNode $ if lvl0 < lvl1 then lvl0 else succ lvl0) (BoxNode lvl1) r0 r1 r2 r3 reduceNode n0@BoxNode {} n1@TMatchNode {} = reduceNode n1 n0 +reduceNode (PArgumentNode _ r0 r1) (BoxNode lvl _ r2) + = commute1 PArgumentNode (BoxNode lvl) r0 r1 r2 +reduceNode n0@BoxNode {} n1@PArgumentNode {} = reduceNode n1 n0 +reduceNode (PReduceNode _ r0) (BoxNode lvl _ r1) + = commute0 PReduceNode (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@PReduceNode {} = reduceNode n1 n0 reduceNode n0 n1 = error . show $ "unexpected node pairing" <> line <> pretty n0 <> line <> pretty n1 {-# INLINABLE reduceNode #-} @@ -952,7 +1234,7 @@ dedupIO lvl r0 r1 r2 = do namep <- newName rn3 <- newNode $ TEntryNode name (B.Constant B.B1) () () rn4 <- newNode $ TEntryNode name (B.Constant B.B0) () () - rn5 <- newNode $ TBuildNode lvl name namep () () () () + rn5 <- newNode $ TBuildNode lvl BuildIO namep () () () () rn6 <- newNode $ AccumIONode mempty () () linkNodes (Ref rn3 1) (Ref rn5 1) linkNodes (Ref rn4 1) (Ref rn5 2) @@ -970,7 +1252,7 @@ reassocPure r0 r1 = do rn4 <- newNode $ LamNode () () () rn5 <- newNode $ AppNode () () () rn6 <- newNode $ LamNode () () () - rn7 <- newNode $ Bind0FNode () () + rn7 <- newNode $ Bind0CNode () () rn8 <- newNode $ AppNode () () () rn9 <- newNode $ AppNode () () () rn10 <- newNode $ BoxNode 0 () () @@ -997,31 +1279,39 @@ reassocPure r0 r1 = do linkNodes r1 $ Ref rn11 0 {-# INLINABLE reassocPure #-} --- | @\a -> IOPure (\b -> Bind1F (Bind0F (a op) b))@ -reassocCont :: HasRewriter sig m => B.Instruction -> Ref -> m () -reassocCont instr r0 = do - name <- newName - let op = B.Reference (B.instrType instr) name +-- | @r0 = \a -> IOPure (\b -> Bind1C r1 (\c -> Bind0C (a c) b))@ +reassocCont :: HasRewriter sig m => Ref -> Ref -> m () +reassocCont r0 r1 = do rn2 <- newNode $ LamNode () () () rn3 <- newNode $ IOPureNode () () rn4 <- newNode $ LamNode () () () - rn5 <- newNode $ Bind1FNode (name B.:= instr) () () - rn6 <- newNode $ Bind0FNode () () - rn7 <- newNode $ AppNode () () () - rn8 <- newNode $ AppNode () () () - rn9 <- newNode $ OperandNode op () - rn10 <- newNode $ BoxNode 0 () () - linkNodes (Ref rn2 1) (Ref rn10 0) + rn5 <- newNode $ Bind1CNode () () () + rn6 <- newNode $ BoxNode 0 () () + rn7 <- newNode $ BoxNode 0 () () + rn8 <- newNode $ LamNode () () () + rn9 <- newNode $ Bind0CNode () () + rn10 <- newNode $ AppNode () () () + rn11 <- newNode $ BoxNode 0 () () + rn12 <- newNode $ BoxNode 0 () () + rn13 <- newNode $ BoxNode 0 () () + rn14 <- newNode $ AppNode () () () + linkNodes (Ref rn2 1) (Ref rn11 0) linkNodes (Ref rn2 2) (Ref rn3 0) linkNodes (Ref rn3 1) (Ref rn4 0) - linkNodes (Ref rn4 1) (Ref rn7 1) + linkNodes (Ref rn4 1) (Ref rn13 0) linkNodes (Ref rn4 2) (Ref rn5 0) - linkNodes (Ref rn5 1) (Ref rn7 2) - linkNodes (Ref rn6 0) (Ref rn8 2) + linkNodes (Ref rn5 1) (Ref rn7 1) + linkNodes (Ref rn5 2) (Ref rn8 0) linkNodes (Ref rn6 1) (Ref rn7 0) - linkNodes (Ref rn8 0) (Ref rn10 1) - linkNodes (Ref rn8 1) (Ref rn9 0) + linkNodes (Ref rn8 1) (Ref rn10 1) + linkNodes (Ref rn8 2) (Ref rn14 2) + linkNodes (Ref rn9 0) (Ref rn10 2) + linkNodes (Ref rn9 1) (Ref rn14 0) + linkNodes (Ref rn10 0) (Ref rn12 1) + linkNodes (Ref rn11 1) (Ref rn12 0) + linkNodes (Ref rn13 1) (Ref rn14 1) linkNodes r0 $ Ref rn2 0 + linkNodes r1 $ Ref rn6 0 {-# INLINABLE reassocCont #-} mkLambda :: HasRewriter sig m => Ref -> (() -> () -> INetF ()) -> m () diff --git a/test/Golden.hs b/test/Golden.hs index 5893b92..bb75743 100644 --- a/test/Golden.hs +++ b/test/Golden.hs @@ -195,15 +195,10 @@ instance (MonadIO m, Has (State Count) sig m, Has (State INet) sig m (_, DeadNode {}) -> pure () (BoxNode {}, _) -> pure () (_, BoxNode {}) -> pure () - -- These nodes might require prettyprinting very large blocks. - (AccumNBNode {}, _) -> pure () - (_, AccumNBNode {}) -> pure () - (IONode {}, _) -> pure () - (_, IONode {}) -> pure () - (NamedBlockNode {}, _) -> pure () - (_, NamedBlockNode {}) -> pure () - (Merge1Node {}, _) -> pure () - (_, Merge1Node {}) -> pure () + (TBuildNode {}, TSplitNode {}) -> pure () + (TSplitNode {}, TBuildNode {}) -> pure () + (TCloseNode {}, _) -> pure () + (_, TCloseNode {}) -> pure () _ -> liftIO $ hPrint h $ pretty count <+> pretty netSize @@ -270,14 +265,15 @@ _Stats = iso unStats Stats data NodeHead = AppHead | LamHead | DupHead | DeadHead | BoxHead | ExternalRootHead | PrivateRootHead | AccumIOHead | AccumNBHead - | OperandHead | OperandPHead - | IOHead | IOPHead | IOPureHead | IOContHead - | ReturnHead - | Bind0BHead | Bind0FHead | Bind1FHead - | Branch0Head | Branch0FHead | Branch1Head + | OperandHead | OperandAHead | OperandPHead + | IOHead | IOAHead | IOPHead | IOPureHead | IOContHead + | ReturnCHead | ReturnFHead + | Bind0BHead | Bind0CHead | Bind0FHead | Bind1CHead | Bind1FHead + | Branch0Head | Branch0CHead | Branch0FHead | Branch1Head | LabelHead | NamedBlockHead | Merge0Head | Merge1Head | TBuildHead | TEntryHead | TSplitHead | TCloseHead | TLeaveHead | TMatchHead + | PArgumentHead | PReduceHead deriving stock (Eq, Ord) instance Pretty NodeHead where @@ -291,16 +287,22 @@ instance Pretty NodeHead where pretty AccumNBHead = "AccumNB" pretty BoxHead = "Box" pretty OperandHead = "Operand" + pretty OperandAHead = "OperandA" pretty OperandPHead = "OperandP" pretty IOHead = "IO" + pretty IOAHead = "IOA" pretty IOPHead = "IOP" pretty IOPureHead = "IOPure" pretty IOContHead = "IOCont" - pretty ReturnHead = "Return" + pretty ReturnCHead = "ReturnC" + pretty ReturnFHead = "ReturnF" pretty Bind0BHead = "Bind0B" + pretty Bind0CHead = "Bind0C" pretty Bind0FHead = "Bind0F" + pretty Bind1CHead = "Bind1C" pretty Bind1FHead = "Bind1F" pretty Branch0Head = "Branch0" + pretty Branch0CHead = "Branch0C" pretty Branch0FHead = "Branch0F" pretty Branch1Head = "Branch1" pretty LabelHead = "Label" @@ -313,6 +315,8 @@ instance Pretty NodeHead where pretty TCloseHead = "TClose" pretty TLeaveHead = "TLeave" pretty TMatchHead = "TMatch" + pretty PArgumentHead = "PArgument" + pretty PReduceHead = "PReduce" nodeHead :: INetF a -> NodeHead nodeHead x = case x of @@ -326,16 +330,22 @@ nodeHead x = case x of AccumIONode {} -> AccumIOHead AccumNBNode {} -> AccumNBHead OperandNode {} -> OperandHead + OperandANode {} -> OperandAHead OperandPNode {} -> OperandPHead IONode {} -> IOHead + IOANode {} -> IOAHead IOPNode {} -> IOPHead IOPureNode {} -> IOPureHead IOContNode {} -> IOContHead - ReturnNode {} -> ReturnHead + ReturnCNode {} -> ReturnCHead + ReturnFNode {} -> ReturnFHead Bind0BNode {} -> Bind0BHead + Bind0CNode {} -> Bind0CHead Bind0FNode {} -> Bind0FHead + Bind1CNode {} -> Bind1CHead Bind1FNode {} -> Bind1FHead Branch0Node {} -> Branch0Head + Branch0CNode {} -> Branch0CHead Branch0FNode {} -> Branch0FHead Branch1Node {} -> Branch1Head LabelNode {} -> LabelHead @@ -348,6 +358,8 @@ nodeHead x = case x of TCloseNode {} -> TCloseHead TLeaveNode {} -> TLeaveHead TMatchNode {} -> TMatchHead + PArgumentNode {} -> PArgumentHead + PReduceNode {} -> PReduceHead hPutDoc :: Handle -> Doc ann -> IO () hPutDoc h doc = renderIO h $ layoutPretty opts doc diff --git a/test/Golden/Arithmetic.opt.ll b/test/Golden/Arithmetic.opt.ll index ee57b50..66ffd0f 100644 --- a/test/Golden/Arithmetic.opt.ll +++ b/test/Golden/Arithmetic.opt.ll @@ -3,11 +3,12 @@ source_filename = "test/Golden/Arithmetic.elem" ; Function Attrs: norecurse nounwind readnone define i1 @expsign(i2, i2) local_unnamed_addr #0 { - %3 = and i2 %0, 1 - %4 = icmp ne i2 %3, 0 - %5 = icmp eq i2 %1, 0 - %spec.select11 = or i1 %5, %4 - ret i1 %spec.select11 +__elem_0.exit: + %2 = and i2 %0, 1 + %3 = icmp ne i2 %2, 0 + %4 = icmp eq i2 %1, 0 + %spec.select = or i1 %4, %3 + ret i1 %spec.select } attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/BitOrder.opt.ll b/test/Golden/BitOrder.opt.ll index ce2b20f..235eefe 100644 --- a/test/Golden/BitOrder.opt.ll +++ b/test/Golden/BitOrder.opt.ll @@ -3,17 +3,9 @@ source_filename = "test/Golden/BitOrder.elem" ; Function Attrs: norecurse nounwind readnone define i2 @main(i2) local_unnamed_addr #0 { - %2 = icmp sgt i2 %0, -1 - %3 = and i2 %0, 1 - br i1 %2, label %6, label %4 - -4: ; preds = %1 - %5 = xor i2 %3, -1 - ret i2 %5 - -6: ; preds = %1 - %7 = xor i2 %3, 1 - ret i2 %7 +__elem_0.exit: + %1 = xor i2 %0, 1 + ret i2 %1 } attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/CallOrder.opt.ll b/test/Golden/CallOrder.opt.ll index 05d1326..8164b11 100644 --- a/test/Golden/CallOrder.opt.ll +++ b/test/Golden/CallOrder.opt.ll @@ -7,58 +7,58 @@ define void @main(i2, i1) local_unnamed_addr { %3 = icmp sgt i2 %0, -1 %4 = and i2 %0, 1 %5 = icmp eq i2 %4, 0 - br i1 %3, label %12, label %6 + br i1 %3, label %11, label %6 6: ; preds = %2 - br i1 %5, label %9, label %codeRepl.i + br i1 %5, label %9, label %7 -codeRepl.i: ; preds = %6 - br i1 %1, label %7, label %8 +7: ; preds = %6 + br i1 %1, label %8, label %codeRepl.i.i -7: ; preds = %codeRepl.i +8: ; preds = %7 tail call void @dothing(i2 -1, i1 true) - br label %__elem_0.1.exit + br label %__elem_0.exit -8: ; preds = %codeRepl.i +codeRepl.i.i: ; preds = %7 tail call void @dothing(i2 -1, i1 false) - br label %__elem_0.1.exit + br label %__elem_0.exit 9: ; preds = %6 - br i1 %1, label %10, label %11 + br i1 %1, label %10, label %codeRepl.i1.i 10: ; preds = %9 tail call void @dothing(i2 -2, i1 true) - br label %__elem_0.1.exit + br label %__elem_0.exit -11: ; preds = %9 +codeRepl.i1.i: ; preds = %9 tail call void @dothing(i2 -2, i1 false) - br label %__elem_0.1.exit + br label %__elem_0.exit -__elem_0.1.exit: ; preds = %16, %17, %14, %13, %10, %11, %8, %7 +__elem_0.exit: ; preds = %15, %codeRepl.i1.i3, %13, %codeRepl.i.i1, %10, %codeRepl.i1.i, %8, %codeRepl.i.i ret void -12: ; preds = %2 - br i1 %5, label %15, label %codeRepl.i1 +11: ; preds = %2 + br i1 %5, label %14, label %12 -codeRepl.i1: ; preds = %12 - br i1 %1, label %13, label %14 +12: ; preds = %11 + br i1 %1, label %13, label %codeRepl.i.i1 -13: ; preds = %codeRepl.i1 +13: ; preds = %12 tail call void @dothing(i2 1, i1 true) - br label %__elem_0.1.exit + br label %__elem_0.exit -14: ; preds = %codeRepl.i1 +codeRepl.i.i1: ; preds = %12 tail call void @dothing(i2 1, i1 false) - br label %__elem_0.1.exit + br label %__elem_0.exit -15: ; preds = %12 - br i1 %1, label %16, label %17 +14: ; preds = %11 + br i1 %1, label %15, label %codeRepl.i1.i3 -16: ; preds = %15 +15: ; preds = %14 tail call void @dothing(i2 0, i1 true) - br label %__elem_0.1.exit + br label %__elem_0.exit -17: ; preds = %15 +codeRepl.i1.i3: ; preds = %14 tail call void @dothing(i2 0, i1 false) - br label %__elem_0.1.exit + br label %__elem_0.exit } diff --git a/test/Golden/EchoChar.opt.ll b/test/Golden/EchoChar.opt.ll index 8996a3e..6629f42 100644 --- a/test/Golden/EchoChar.opt.ll +++ b/test/Golden/EchoChar.opt.ll @@ -6,1864 +6,6 @@ declare void @putchar(i8) local_unnamed_addr ; Function Attrs: nofree nounwind declare i8 @getchar() local_unnamed_addr #0 -define private fastcc void @__elem_2(i1, i8, i1, i1) unnamed_addr { - %5 = and i8 %1, 16 - %6 = icmp eq i8 %5, 0 - %7 = and i8 %1, 8 - %8 = icmp eq i8 %7, 0 - br i1 %6, label %11, label %9 - -9: ; preds = %4 - br i1 %8, label %10, label %codeRepl.i - -codeRepl.i: ; preds = %9 - tail call fastcc void @__elem_4(i1 true, i8 %1, i1 %2, i1 %3, i1 %0, i1 true) - br label %__elem_3.2.exit - -10: ; preds = %9 - tail call fastcc void @__elem_4(i1 false, i8 %1, i1 %2, i1 %3, i1 %0, i1 true) - br label %__elem_3.2.exit - -__elem_3.2.exit: ; preds = %codeRepl.i1, %12, %10, %codeRepl.i - ret void - -11: ; preds = %4 - br i1 %8, label %12, label %codeRepl.i1 - -codeRepl.i1: ; preds = %11 - tail call fastcc void @__elem_4(i1 true, i8 %1, i1 %2, i1 %3, i1 %0, i1 false) - br label %__elem_3.2.exit - -12: ; preds = %11 - tail call fastcc void @__elem_4(i1 false, i8 %1, i1 %2, i1 %3, i1 %0, i1 false) - br label %__elem_3.2.exit -} - -define private fastcc void @__elem_4(i1, i8, i1, i1, i1, i1) unnamed_addr { - %7 = and i8 %1, 4 - %8 = icmp eq i8 %7, 0 - %9 = and i8 %1, 2 - %10 = icmp eq i8 %9, 0 - br i1 %8, label %13, label %11 - -11: ; preds = %6 - br i1 %10, label %12, label %codeRepl.i - -codeRepl.i: ; preds = %11 - tail call fastcc void @__elem_6(i1 true, i8 %1, i1 %2, i1 %3, i1 %4, i1 %5, i1 %0, i1 true) - br label %__elem_5.1.exit - -12: ; preds = %11 - tail call fastcc void @__elem_6(i1 false, i8 %1, i1 %2, i1 %3, i1 %4, i1 %5, i1 %0, i1 true) - br label %__elem_5.1.exit - -__elem_5.1.exit: ; preds = %codeRepl.i1, %14, %12, %codeRepl.i - ret void - -13: ; preds = %6 - br i1 %10, label %14, label %codeRepl.i1 - -codeRepl.i1: ; preds = %13 - tail call fastcc void @__elem_6(i1 true, i8 %1, i1 %2, i1 %3, i1 %4, i1 %5, i1 %0, i1 false) - br label %__elem_5.1.exit - -14: ; preds = %13 - tail call fastcc void @__elem_6(i1 false, i8 %1, i1 %2, i1 %3, i1 %4, i1 %5, i1 %0, i1 false) - br label %__elem_5.1.exit -} - -define private fastcc void @__elem_6(i1, i8, i1, i1, i1, i1, i1, i1) unnamed_addr { - %9 = and i8 %1, 1 - %10 = icmp eq i8 %9, 0 - br i1 %10, label %12, label %11 - -11: ; preds = %8 - br i1 %2, label %13, label %14 - -12: ; preds = %8 - br i1 %2, label %15, label %16 - -13: ; preds = %11 - br i1 %3, label %17, label %18 - -14: ; preds = %11 - br i1 %3, label %47, label %48 - -15: ; preds = %12 - br i1 %3, label %77, label %78 - -16: ; preds = %12 - br i1 %3, label %107, label %108 - -17: ; preds = %13 - br i1 %4, label %19, label %20 - -18: ; preds = %13 - br i1 %4, label %33, label %34 - -19: ; preds = %17 - br i1 %5, label %21, label %22 - -20: ; preds = %17 - br i1 %5, label %27, label %28 - -21: ; preds = %19 - br i1 %6, label %23, label %24 - -22: ; preds = %19 - br i1 %6, label %25, label %26 - -23: ; preds = %21 - br i1 %7, label %137, label %138 - -24: ; preds = %21 - br i1 %7, label %139, label %140 - -25: ; preds = %22 - br i1 %7, label %141, label %142 - -26: ; preds = %22 - br i1 %7, label %143, label %144 - -27: ; preds = %20 - br i1 %6, label %29, label %30 - -28: ; preds = %20 - br i1 %6, label %31, label %32 - -29: ; preds = %27 - br i1 %7, label %145, label %146 - -30: ; preds = %27 - br i1 %7, label %147, label %148 - -31: ; preds = %28 - br i1 %7, label %149, label %150 - -32: ; preds = %28 - br i1 %7, label %151, label %152 - -33: ; preds = %18 - br i1 %5, label %35, label %36 - -34: ; preds = %18 - br i1 %5, label %41, label %42 - -35: ; preds = %33 - br i1 %6, label %37, label %38 - -36: ; preds = %33 - br i1 %6, label %39, label %40 - -37: ; preds = %35 - br i1 %7, label %153, label %154 - -38: ; preds = %35 - br i1 %7, label %155, label %156 - -39: ; preds = %36 - br i1 %7, label %157, label %158 - -40: ; preds = %36 - br i1 %7, label %159, label %160 - -41: ; preds = %34 - br i1 %6, label %43, label %44 - -42: ; preds = %34 - br i1 %6, label %45, label %46 - -43: ; preds = %41 - br i1 %7, label %161, label %162 - -44: ; preds = %41 - br i1 %7, label %163, label %164 - -45: ; preds = %42 - br i1 %7, label %165, label %166 - -46: ; preds = %42 - br i1 %7, label %167, label %168 - -47: ; preds = %14 - br i1 %4, label %49, label %50 - -48: ; preds = %14 - br i1 %4, label %63, label %64 - -49: ; preds = %47 - br i1 %5, label %51, label %52 - -50: ; preds = %47 - br i1 %5, label %57, label %58 - -51: ; preds = %49 - br i1 %6, label %53, label %54 - -52: ; preds = %49 - br i1 %6, label %55, label %56 - -53: ; preds = %51 - br i1 %7, label %169, label %170 - -54: ; preds = %51 - br i1 %7, label %171, label %172 - -55: ; preds = %52 - br i1 %7, label %173, label %174 - -56: ; preds = %52 - br i1 %7, label %175, label %176 - -57: ; preds = %50 - br i1 %6, label %59, label %60 - -58: ; preds = %50 - br i1 %6, label %61, label %62 - -59: ; preds = %57 - br i1 %7, label %177, label %178 - -60: ; preds = %57 - br i1 %7, label %179, label %180 - -61: ; preds = %58 - br i1 %7, label %181, label %182 - -62: ; preds = %58 - br i1 %7, label %183, label %184 - -63: ; preds = %48 - br i1 %5, label %65, label %66 - -64: ; preds = %48 - br i1 %5, label %71, label %72 - -65: ; preds = %63 - br i1 %6, label %67, label %68 - -66: ; preds = %63 - br i1 %6, label %69, label %70 - -67: ; preds = %65 - br i1 %7, label %185, label %186 - -68: ; preds = %65 - br i1 %7, label %187, label %188 - -69: ; preds = %66 - br i1 %7, label %189, label %190 - -70: ; preds = %66 - br i1 %7, label %191, label %192 - -71: ; preds = %64 - br i1 %6, label %73, label %74 - -72: ; preds = %64 - br i1 %6, label %75, label %76 - -73: ; preds = %71 - br i1 %7, label %193, label %194 - -74: ; preds = %71 - br i1 %7, label %195, label %196 - -75: ; preds = %72 - br i1 %7, label %197, label %198 - -76: ; preds = %72 - br i1 %7, label %199, label %200 - -77: ; preds = %15 - br i1 %4, label %79, label %80 - -78: ; preds = %15 - br i1 %4, label %93, label %94 - -79: ; preds = %77 - br i1 %5, label %81, label %82 - -80: ; preds = %77 - br i1 %5, label %87, label %88 - -81: ; preds = %79 - br i1 %6, label %83, label %84 - -82: ; preds = %79 - br i1 %6, label %85, label %86 - -83: ; preds = %81 - br i1 %7, label %201, label %202 - -84: ; preds = %81 - br i1 %7, label %203, label %204 - -85: ; preds = %82 - br i1 %7, label %205, label %206 - -86: ; preds = %82 - br i1 %7, label %207, label %208 - -87: ; preds = %80 - br i1 %6, label %89, label %90 - -88: ; preds = %80 - br i1 %6, label %91, label %92 - -89: ; preds = %87 - br i1 %7, label %209, label %210 - -90: ; preds = %87 - br i1 %7, label %211, label %212 - -91: ; preds = %88 - br i1 %7, label %213, label %214 - -92: ; preds = %88 - br i1 %7, label %215, label %216 - -93: ; preds = %78 - br i1 %5, label %95, label %96 - -94: ; preds = %78 - br i1 %5, label %101, label %102 - -95: ; preds = %93 - br i1 %6, label %97, label %98 - -96: ; preds = %93 - br i1 %6, label %99, label %100 - -97: ; preds = %95 - br i1 %7, label %217, label %218 - -98: ; preds = %95 - br i1 %7, label %219, label %220 - -99: ; preds = %96 - br i1 %7, label %221, label %222 - -100: ; preds = %96 - br i1 %7, label %223, label %224 - -101: ; preds = %94 - br i1 %6, label %103, label %104 - -102: ; preds = %94 - br i1 %6, label %105, label %106 - -103: ; preds = %101 - br i1 %7, label %225, label %226 - -104: ; preds = %101 - br i1 %7, label %227, label %228 - -105: ; preds = %102 - br i1 %7, label %229, label %230 - -106: ; preds = %102 - br i1 %7, label %231, label %232 - -107: ; preds = %16 - br i1 %4, label %109, label %110 - -108: ; preds = %16 - br i1 %4, label %123, label %124 - -109: ; preds = %107 - br i1 %5, label %111, label %112 - -110: ; preds = %107 - br i1 %5, label %117, label %118 - -111: ; preds = %109 - br i1 %6, label %113, label %114 - -112: ; preds = %109 - br i1 %6, label %115, label %116 - -113: ; preds = %111 - br i1 %7, label %233, label %234 - -114: ; preds = %111 - br i1 %7, label %235, label %236 - -115: ; preds = %112 - br i1 %7, label %237, label %238 - -116: ; preds = %112 - br i1 %7, label %239, label %240 - -117: ; preds = %110 - br i1 %6, label %119, label %120 - -118: ; preds = %110 - br i1 %6, label %121, label %122 - -119: ; preds = %117 - br i1 %7, label %241, label %242 - -120: ; preds = %117 - br i1 %7, label %243, label %244 - -121: ; preds = %118 - br i1 %7, label %245, label %246 - -122: ; preds = %118 - br i1 %7, label %247, label %248 - -123: ; preds = %108 - br i1 %5, label %125, label %126 - -124: ; preds = %108 - br i1 %5, label %131, label %132 - -125: ; preds = %123 - br i1 %6, label %127, label %128 - -126: ; preds = %123 - br i1 %6, label %129, label %130 - -127: ; preds = %125 - br i1 %7, label %249, label %250 - -128: ; preds = %125 - br i1 %7, label %251, label %252 - -129: ; preds = %126 - br i1 %7, label %253, label %254 - -130: ; preds = %126 - br i1 %7, label %255, label %256 - -131: ; preds = %124 - br i1 %6, label %133, label %134 - -132: ; preds = %124 - br i1 %6, label %135, label %136 - -133: ; preds = %131 - br i1 %7, label %257, label %258 - -134: ; preds = %131 - br i1 %7, label %259, label %260 - -135: ; preds = %132 - br i1 %7, label %261, label %262 - -136: ; preds = %132 - br i1 %7, label %263, label %264 - -137: ; preds = %23 - br i1 %0, label %265, label %266 - -138: ; preds = %23 - br i1 %0, label %267, label %268 - -139: ; preds = %24 - br i1 %0, label %269, label %270 - -140: ; preds = %24 - br i1 %0, label %271, label %272 - -141: ; preds = %25 - br i1 %0, label %273, label %274 - -142: ; preds = %25 - br i1 %0, label %275, label %276 - -143: ; preds = %26 - br i1 %0, label %277, label %278 - -144: ; preds = %26 - br i1 %0, label %279, label %280 - -145: ; preds = %29 - br i1 %0, label %281, label %282 - -146: ; preds = %29 - br i1 %0, label %283, label %284 - -147: ; preds = %30 - br i1 %0, label %285, label %286 - -148: ; preds = %30 - br i1 %0, label %287, label %288 - -149: ; preds = %31 - br i1 %0, label %289, label %290 - -150: ; preds = %31 - br i1 %0, label %291, label %292 - -151: ; preds = %32 - br i1 %0, label %293, label %294 - -152: ; preds = %32 - br i1 %0, label %295, label %296 - -153: ; preds = %37 - br i1 %0, label %297, label %298 - -154: ; preds = %37 - br i1 %0, label %299, label %300 - -155: ; preds = %38 - br i1 %0, label %301, label %302 - -156: ; preds = %38 - br i1 %0, label %303, label %304 - -157: ; preds = %39 - br i1 %0, label %305, label %306 - -158: ; preds = %39 - br i1 %0, label %307, label %308 - -159: ; preds = %40 - br i1 %0, label %309, label %310 - -160: ; preds = %40 - br i1 %0, label %311, label %312 - -161: ; preds = %43 - br i1 %0, label %313, label %314 - -162: ; preds = %43 - br i1 %0, label %315, label %316 - -163: ; preds = %44 - br i1 %0, label %317, label %318 - -164: ; preds = %44 - br i1 %0, label %319, label %320 - -165: ; preds = %45 - br i1 %0, label %321, label %322 - -166: ; preds = %45 - br i1 %0, label %323, label %324 - -167: ; preds = %46 - br i1 %0, label %325, label %326 - -168: ; preds = %46 - br i1 %0, label %327, label %328 - -169: ; preds = %53 - br i1 %0, label %329, label %330 - -170: ; preds = %53 - br i1 %0, label %331, label %332 - -171: ; preds = %54 - br i1 %0, label %333, label %334 - -172: ; preds = %54 - br i1 %0, label %335, label %336 - -173: ; preds = %55 - br i1 %0, label %337, label %338 - -174: ; preds = %55 - br i1 %0, label %339, label %340 - -175: ; preds = %56 - br i1 %0, label %341, label %342 - -176: ; preds = %56 - br i1 %0, label %343, label %344 - -177: ; preds = %59 - br i1 %0, label %345, label %346 - -178: ; preds = %59 - br i1 %0, label %347, label %348 - -179: ; preds = %60 - br i1 %0, label %349, label %350 - -180: ; preds = %60 - br i1 %0, label %351, label %352 - -181: ; preds = %61 - br i1 %0, label %353, label %354 - -182: ; preds = %61 - br i1 %0, label %355, label %356 - -183: ; preds = %62 - br i1 %0, label %357, label %358 - -184: ; preds = %62 - br i1 %0, label %359, label %360 - -185: ; preds = %67 - br i1 %0, label %361, label %362 - -186: ; preds = %67 - br i1 %0, label %363, label %364 - -187: ; preds = %68 - br i1 %0, label %365, label %366 - -188: ; preds = %68 - br i1 %0, label %367, label %368 - -189: ; preds = %69 - br i1 %0, label %369, label %370 - -190: ; preds = %69 - br i1 %0, label %371, label %372 - -191: ; preds = %70 - br i1 %0, label %373, label %374 - -192: ; preds = %70 - br i1 %0, label %375, label %376 - -193: ; preds = %73 - br i1 %0, label %377, label %378 - -194: ; preds = %73 - br i1 %0, label %379, label %380 - -195: ; preds = %74 - br i1 %0, label %381, label %382 - -196: ; preds = %74 - br i1 %0, label %383, label %384 - -197: ; preds = %75 - br i1 %0, label %385, label %386 - -198: ; preds = %75 - br i1 %0, label %387, label %388 - -199: ; preds = %76 - br i1 %0, label %389, label %390 - -200: ; preds = %76 - br i1 %0, label %391, label %392 - -201: ; preds = %83 - br i1 %0, label %393, label %394 - -202: ; preds = %83 - br i1 %0, label %395, label %396 - -203: ; preds = %84 - br i1 %0, label %397, label %398 - -204: ; preds = %84 - br i1 %0, label %399, label %400 - -205: ; preds = %85 - br i1 %0, label %401, label %402 - -206: ; preds = %85 - br i1 %0, label %403, label %404 - -207: ; preds = %86 - br i1 %0, label %405, label %406 - -208: ; preds = %86 - br i1 %0, label %407, label %408 - -209: ; preds = %89 - br i1 %0, label %409, label %410 - -210: ; preds = %89 - br i1 %0, label %411, label %412 - -211: ; preds = %90 - br i1 %0, label %413, label %414 - -212: ; preds = %90 - br i1 %0, label %415, label %416 - -213: ; preds = %91 - br i1 %0, label %417, label %418 - -214: ; preds = %91 - br i1 %0, label %419, label %420 - -215: ; preds = %92 - br i1 %0, label %421, label %422 - -216: ; preds = %92 - br i1 %0, label %423, label %424 - -217: ; preds = %97 - br i1 %0, label %425, label %426 - -218: ; preds = %97 - br i1 %0, label %427, label %428 - -219: ; preds = %98 - br i1 %0, label %429, label %430 - -220: ; preds = %98 - br i1 %0, label %431, label %432 - -221: ; preds = %99 - br i1 %0, label %433, label %434 - -222: ; preds = %99 - br i1 %0, label %435, label %436 - -223: ; preds = %100 - br i1 %0, label %437, label %438 - -224: ; preds = %100 - br i1 %0, label %439, label %440 - -225: ; preds = %103 - br i1 %0, label %441, label %442 - -226: ; preds = %103 - br i1 %0, label %443, label %444 - -227: ; preds = %104 - br i1 %0, label %445, label %446 - -228: ; preds = %104 - br i1 %0, label %447, label %448 - -229: ; preds = %105 - br i1 %0, label %449, label %450 - -230: ; preds = %105 - br i1 %0, label %451, label %452 - -231: ; preds = %106 - br i1 %0, label %453, label %454 - -232: ; preds = %106 - br i1 %0, label %455, label %456 - -233: ; preds = %113 - br i1 %0, label %457, label %458 - -234: ; preds = %113 - br i1 %0, label %459, label %460 - -235: ; preds = %114 - br i1 %0, label %461, label %462 - -236: ; preds = %114 - br i1 %0, label %463, label %464 - -237: ; preds = %115 - br i1 %0, label %465, label %466 - -238: ; preds = %115 - br i1 %0, label %467, label %468 - -239: ; preds = %116 - br i1 %0, label %469, label %470 - -240: ; preds = %116 - br i1 %0, label %471, label %472 - -241: ; preds = %119 - br i1 %0, label %473, label %474 - -242: ; preds = %119 - br i1 %0, label %475, label %476 - -243: ; preds = %120 - br i1 %0, label %477, label %478 - -244: ; preds = %120 - br i1 %0, label %479, label %480 - -245: ; preds = %121 - br i1 %0, label %481, label %482 - -246: ; preds = %121 - br i1 %0, label %483, label %484 - -247: ; preds = %122 - br i1 %0, label %485, label %486 - -248: ; preds = %122 - br i1 %0, label %487, label %488 - -249: ; preds = %127 - br i1 %0, label %489, label %490 - -250: ; preds = %127 - br i1 %0, label %491, label %492 - -251: ; preds = %128 - br i1 %0, label %493, label %494 - -252: ; preds = %128 - br i1 %0, label %495, label %496 - -253: ; preds = %129 - br i1 %0, label %497, label %498 - -254: ; preds = %129 - br i1 %0, label %499, label %500 - -255: ; preds = %130 - br i1 %0, label %501, label %502 - -256: ; preds = %130 - br i1 %0, label %503, label %504 - -257: ; preds = %133 - br i1 %0, label %505, label %506 - -258: ; preds = %133 - br i1 %0, label %507, label %508 - -259: ; preds = %134 - br i1 %0, label %509, label %510 - -260: ; preds = %134 - br i1 %0, label %511, label %512 - -261: ; preds = %135 - br i1 %0, label %513, label %514 - -262: ; preds = %135 - br i1 %0, label %515, label %516 - -263: ; preds = %136 - br i1 %0, label %517, label %518 - -264: ; preds = %136 - br i1 %0, label %519, label %520 - -265: ; preds = %137 - tail call void @putchar(i8 -1) - ret void - -266: ; preds = %137 - tail call void @putchar(i8 -3) - ret void - -267: ; preds = %138 - tail call void @putchar(i8 -5) - ret void - -268: ; preds = %138 - tail call void @putchar(i8 -7) - ret void - -269: ; preds = %139 - tail call void @putchar(i8 -9) - ret void - -270: ; preds = %139 - tail call void @putchar(i8 -11) - ret void - -271: ; preds = %140 - tail call void @putchar(i8 -13) - ret void - -272: ; preds = %140 - tail call void @putchar(i8 -15) - ret void - -273: ; preds = %141 - tail call void @putchar(i8 -17) - ret void - -274: ; preds = %141 - tail call void @putchar(i8 -19) - ret void - -275: ; preds = %142 - tail call void @putchar(i8 -21) - ret void - -276: ; preds = %142 - tail call void @putchar(i8 -23) - ret void - -277: ; preds = %143 - tail call void @putchar(i8 -25) - ret void - -278: ; preds = %143 - tail call void @putchar(i8 -27) - ret void - -279: ; preds = %144 - tail call void @putchar(i8 -29) - ret void - -280: ; preds = %144 - tail call void @putchar(i8 -31) - ret void - -281: ; preds = %145 - tail call void @putchar(i8 -33) - ret void - -282: ; preds = %145 - tail call void @putchar(i8 -35) - ret void - -283: ; preds = %146 - tail call void @putchar(i8 -37) - ret void - -284: ; preds = %146 - tail call void @putchar(i8 -39) - ret void - -285: ; preds = %147 - tail call void @putchar(i8 -41) - ret void - -286: ; preds = %147 - tail call void @putchar(i8 -43) - ret void - -287: ; preds = %148 - tail call void @putchar(i8 -45) - ret void - -288: ; preds = %148 - tail call void @putchar(i8 -47) - ret void - -289: ; preds = %149 - tail call void @putchar(i8 -49) - ret void - -290: ; preds = %149 - tail call void @putchar(i8 -51) - ret void - -291: ; preds = %150 - tail call void @putchar(i8 -53) - ret void - -292: ; preds = %150 - tail call void @putchar(i8 -55) - ret void - -293: ; preds = %151 - tail call void @putchar(i8 -57) - ret void - -294: ; preds = %151 - tail call void @putchar(i8 -59) - ret void - -295: ; preds = %152 - tail call void @putchar(i8 -61) - ret void - -296: ; preds = %152 - tail call void @putchar(i8 -63) - ret void - -297: ; preds = %153 - tail call void @putchar(i8 -65) - ret void - -298: ; preds = %153 - tail call void @putchar(i8 -67) - ret void - -299: ; preds = %154 - tail call void @putchar(i8 -69) - ret void - -300: ; preds = %154 - tail call void @putchar(i8 -71) - ret void - -301: ; preds = %155 - tail call void @putchar(i8 -73) - ret void - -302: ; preds = %155 - tail call void @putchar(i8 -75) - ret void - -303: ; preds = %156 - tail call void @putchar(i8 -77) - ret void - -304: ; preds = %156 - tail call void @putchar(i8 -79) - ret void - -305: ; preds = %157 - tail call void @putchar(i8 -81) - ret void - -306: ; preds = %157 - tail call void @putchar(i8 -83) - ret void - -307: ; preds = %158 - tail call void @putchar(i8 -85) - ret void - -308: ; preds = %158 - tail call void @putchar(i8 -87) - ret void - -309: ; preds = %159 - tail call void @putchar(i8 -89) - ret void - -310: ; preds = %159 - tail call void @putchar(i8 -91) - ret void - -311: ; preds = %160 - tail call void @putchar(i8 -93) - ret void - -312: ; preds = %160 - tail call void @putchar(i8 -95) - ret void - -313: ; preds = %161 - tail call void @putchar(i8 -97) - ret void - -314: ; preds = %161 - tail call void @putchar(i8 -99) - ret void - -315: ; preds = %162 - tail call void @putchar(i8 -101) - ret void - -316: ; preds = %162 - tail call void @putchar(i8 -103) - ret void - -317: ; preds = %163 - tail call void @putchar(i8 -105) - ret void - -318: ; preds = %163 - tail call void @putchar(i8 -107) - ret void - -319: ; preds = %164 - tail call void @putchar(i8 -109) - ret void - -320: ; preds = %164 - tail call void @putchar(i8 -111) - ret void - -321: ; preds = %165 - tail call void @putchar(i8 -113) - ret void - -322: ; preds = %165 - tail call void @putchar(i8 -115) - ret void - -323: ; preds = %166 - tail call void @putchar(i8 -117) - ret void - -324: ; preds = %166 - tail call void @putchar(i8 -119) - ret void - -325: ; preds = %167 - tail call void @putchar(i8 -121) - ret void - -326: ; preds = %167 - tail call void @putchar(i8 -123) - ret void - -327: ; preds = %168 - tail call void @putchar(i8 -125) - ret void - -328: ; preds = %168 - tail call void @putchar(i8 -127) - ret void - -329: ; preds = %169 - tail call void @putchar(i8 127) - ret void - -330: ; preds = %169 - tail call void @putchar(i8 125) - ret void - -331: ; preds = %170 - tail call void @putchar(i8 123) - ret void - -332: ; preds = %170 - tail call void @putchar(i8 121) - ret void - -333: ; preds = %171 - tail call void @putchar(i8 119) - ret void - -334: ; preds = %171 - tail call void @putchar(i8 117) - ret void - -335: ; preds = %172 - tail call void @putchar(i8 115) - ret void - -336: ; preds = %172 - tail call void @putchar(i8 113) - ret void - -337: ; preds = %173 - tail call void @putchar(i8 111) - ret void - -338: ; preds = %173 - tail call void @putchar(i8 109) - ret void - -339: ; preds = %174 - tail call void @putchar(i8 107) - ret void - -340: ; preds = %174 - tail call void @putchar(i8 105) - ret void - -341: ; preds = %175 - tail call void @putchar(i8 103) - ret void - -342: ; preds = %175 - tail call void @putchar(i8 101) - ret void - -343: ; preds = %176 - tail call void @putchar(i8 99) - ret void - -344: ; preds = %176 - tail call void @putchar(i8 97) - ret void - -345: ; preds = %177 - tail call void @putchar(i8 95) - ret void - -346: ; preds = %177 - tail call void @putchar(i8 93) - ret void - -347: ; preds = %178 - tail call void @putchar(i8 91) - ret void - -348: ; preds = %178 - tail call void @putchar(i8 89) - ret void - -349: ; preds = %179 - tail call void @putchar(i8 87) - ret void - -350: ; preds = %179 - tail call void @putchar(i8 85) - ret void - -351: ; preds = %180 - tail call void @putchar(i8 83) - ret void - -352: ; preds = %180 - tail call void @putchar(i8 81) - ret void - -353: ; preds = %181 - tail call void @putchar(i8 79) - ret void - -354: ; preds = %181 - tail call void @putchar(i8 77) - ret void - -355: ; preds = %182 - tail call void @putchar(i8 75) - ret void - -356: ; preds = %182 - tail call void @putchar(i8 73) - ret void - -357: ; preds = %183 - tail call void @putchar(i8 71) - ret void - -358: ; preds = %183 - tail call void @putchar(i8 69) - ret void - -359: ; preds = %184 - tail call void @putchar(i8 67) - ret void - -360: ; preds = %184 - tail call void @putchar(i8 65) - ret void - -361: ; preds = %185 - tail call void @putchar(i8 63) - ret void - -362: ; preds = %185 - tail call void @putchar(i8 61) - ret void - -363: ; preds = %186 - tail call void @putchar(i8 59) - ret void - -364: ; preds = %186 - tail call void @putchar(i8 57) - ret void - -365: ; preds = %187 - tail call void @putchar(i8 55) - ret void - -366: ; preds = %187 - tail call void @putchar(i8 53) - ret void - -367: ; preds = %188 - tail call void @putchar(i8 51) - ret void - -368: ; preds = %188 - tail call void @putchar(i8 49) - ret void - -369: ; preds = %189 - tail call void @putchar(i8 47) - ret void - -370: ; preds = %189 - tail call void @putchar(i8 45) - ret void - -371: ; preds = %190 - tail call void @putchar(i8 43) - ret void - -372: ; preds = %190 - tail call void @putchar(i8 41) - ret void - -373: ; preds = %191 - tail call void @putchar(i8 39) - ret void - -374: ; preds = %191 - tail call void @putchar(i8 37) - ret void - -375: ; preds = %192 - tail call void @putchar(i8 35) - ret void - -376: ; preds = %192 - tail call void @putchar(i8 33) - ret void - -377: ; preds = %193 - tail call void @putchar(i8 31) - ret void - -378: ; preds = %193 - tail call void @putchar(i8 29) - ret void - -379: ; preds = %194 - tail call void @putchar(i8 27) - ret void - -380: ; preds = %194 - tail call void @putchar(i8 25) - ret void - -381: ; preds = %195 - tail call void @putchar(i8 23) - ret void - -382: ; preds = %195 - tail call void @putchar(i8 21) - ret void - -383: ; preds = %196 - tail call void @putchar(i8 19) - ret void - -384: ; preds = %196 - tail call void @putchar(i8 17) - ret void - -385: ; preds = %197 - tail call void @putchar(i8 15) - ret void - -386: ; preds = %197 - tail call void @putchar(i8 13) - ret void - -387: ; preds = %198 - tail call void @putchar(i8 11) - ret void - -388: ; preds = %198 - tail call void @putchar(i8 9) - ret void - -389: ; preds = %199 - tail call void @putchar(i8 7) - ret void - -390: ; preds = %199 - tail call void @putchar(i8 5) - ret void - -391: ; preds = %200 - tail call void @putchar(i8 3) - ret void - -392: ; preds = %200 - tail call void @putchar(i8 1) - ret void - -393: ; preds = %201 - tail call void @putchar(i8 -2) - ret void - -394: ; preds = %201 - tail call void @putchar(i8 -4) - ret void - -395: ; preds = %202 - tail call void @putchar(i8 -6) - ret void - -396: ; preds = %202 - tail call void @putchar(i8 -8) - ret void - -397: ; preds = %203 - tail call void @putchar(i8 -10) - ret void - -398: ; preds = %203 - tail call void @putchar(i8 -12) - ret void - -399: ; preds = %204 - tail call void @putchar(i8 -14) - ret void - -400: ; preds = %204 - tail call void @putchar(i8 -16) - ret void - -401: ; preds = %205 - tail call void @putchar(i8 -18) - ret void - -402: ; preds = %205 - tail call void @putchar(i8 -20) - ret void - -403: ; preds = %206 - tail call void @putchar(i8 -22) - ret void - -404: ; preds = %206 - tail call void @putchar(i8 -24) - ret void - -405: ; preds = %207 - tail call void @putchar(i8 -26) - ret void - -406: ; preds = %207 - tail call void @putchar(i8 -28) - ret void - -407: ; preds = %208 - tail call void @putchar(i8 -30) - ret void - -408: ; preds = %208 - tail call void @putchar(i8 -32) - ret void - -409: ; preds = %209 - tail call void @putchar(i8 -34) - ret void - -410: ; preds = %209 - tail call void @putchar(i8 -36) - ret void - -411: ; preds = %210 - tail call void @putchar(i8 -38) - ret void - -412: ; preds = %210 - tail call void @putchar(i8 -40) - ret void - -413: ; preds = %211 - tail call void @putchar(i8 -42) - ret void - -414: ; preds = %211 - tail call void @putchar(i8 -44) - ret void - -415: ; preds = %212 - tail call void @putchar(i8 -46) - ret void - -416: ; preds = %212 - tail call void @putchar(i8 -48) - ret void - -417: ; preds = %213 - tail call void @putchar(i8 -50) - ret void - -418: ; preds = %213 - tail call void @putchar(i8 -52) - ret void - -419: ; preds = %214 - tail call void @putchar(i8 -54) - ret void - -420: ; preds = %214 - tail call void @putchar(i8 -56) - ret void - -421: ; preds = %215 - tail call void @putchar(i8 -58) - ret void - -422: ; preds = %215 - tail call void @putchar(i8 -60) - ret void - -423: ; preds = %216 - tail call void @putchar(i8 -62) - ret void - -424: ; preds = %216 - tail call void @putchar(i8 -64) - ret void - -425: ; preds = %217 - tail call void @putchar(i8 -66) - ret void - -426: ; preds = %217 - tail call void @putchar(i8 -68) - ret void - -427: ; preds = %218 - tail call void @putchar(i8 -70) - ret void - -428: ; preds = %218 - tail call void @putchar(i8 -72) - ret void - -429: ; preds = %219 - tail call void @putchar(i8 -74) - ret void - -430: ; preds = %219 - tail call void @putchar(i8 -76) - ret void - -431: ; preds = %220 - tail call void @putchar(i8 -78) - ret void - -432: ; preds = %220 - tail call void @putchar(i8 -80) - ret void - -433: ; preds = %221 - tail call void @putchar(i8 -82) - ret void - -434: ; preds = %221 - tail call void @putchar(i8 -84) - ret void - -435: ; preds = %222 - tail call void @putchar(i8 -86) - ret void - -436: ; preds = %222 - tail call void @putchar(i8 -88) - ret void - -437: ; preds = %223 - tail call void @putchar(i8 -90) - ret void - -438: ; preds = %223 - tail call void @putchar(i8 -92) - ret void - -439: ; preds = %224 - tail call void @putchar(i8 -94) - ret void - -440: ; preds = %224 - tail call void @putchar(i8 -96) - ret void - -441: ; preds = %225 - tail call void @putchar(i8 -98) - ret void - -442: ; preds = %225 - tail call void @putchar(i8 -100) - ret void - -443: ; preds = %226 - tail call void @putchar(i8 -102) - ret void - -444: ; preds = %226 - tail call void @putchar(i8 -104) - ret void - -445: ; preds = %227 - tail call void @putchar(i8 -106) - ret void - -446: ; preds = %227 - tail call void @putchar(i8 -108) - ret void - -447: ; preds = %228 - tail call void @putchar(i8 -110) - ret void - -448: ; preds = %228 - tail call void @putchar(i8 -112) - ret void - -449: ; preds = %229 - tail call void @putchar(i8 -114) - ret void - -450: ; preds = %229 - tail call void @putchar(i8 -116) - ret void - -451: ; preds = %230 - tail call void @putchar(i8 -118) - ret void - -452: ; preds = %230 - tail call void @putchar(i8 -120) - ret void - -453: ; preds = %231 - tail call void @putchar(i8 -122) - ret void - -454: ; preds = %231 - tail call void @putchar(i8 -124) - ret void - -455: ; preds = %232 - tail call void @putchar(i8 -126) - ret void - -456: ; preds = %232 - tail call void @putchar(i8 -128) - ret void - -457: ; preds = %233 - tail call void @putchar(i8 126) - ret void - -458: ; preds = %233 - tail call void @putchar(i8 124) - ret void - -459: ; preds = %234 - tail call void @putchar(i8 122) - ret void - -460: ; preds = %234 - tail call void @putchar(i8 120) - ret void - -461: ; preds = %235 - tail call void @putchar(i8 118) - ret void - -462: ; preds = %235 - tail call void @putchar(i8 116) - ret void - -463: ; preds = %236 - tail call void @putchar(i8 114) - ret void - -464: ; preds = %236 - tail call void @putchar(i8 112) - ret void - -465: ; preds = %237 - tail call void @putchar(i8 110) - ret void - -466: ; preds = %237 - tail call void @putchar(i8 108) - ret void - -467: ; preds = %238 - tail call void @putchar(i8 106) - ret void - -468: ; preds = %238 - tail call void @putchar(i8 104) - ret void - -469: ; preds = %239 - tail call void @putchar(i8 102) - ret void - -470: ; preds = %239 - tail call void @putchar(i8 100) - ret void - -471: ; preds = %240 - tail call void @putchar(i8 98) - ret void - -472: ; preds = %240 - tail call void @putchar(i8 96) - ret void - -473: ; preds = %241 - tail call void @putchar(i8 94) - ret void - -474: ; preds = %241 - tail call void @putchar(i8 92) - ret void - -475: ; preds = %242 - tail call void @putchar(i8 90) - ret void - -476: ; preds = %242 - tail call void @putchar(i8 88) - ret void - -477: ; preds = %243 - tail call void @putchar(i8 86) - ret void - -478: ; preds = %243 - tail call void @putchar(i8 84) - ret void - -479: ; preds = %244 - tail call void @putchar(i8 82) - ret void - -480: ; preds = %244 - tail call void @putchar(i8 80) - ret void - -481: ; preds = %245 - tail call void @putchar(i8 78) - ret void - -482: ; preds = %245 - tail call void @putchar(i8 76) - ret void - -483: ; preds = %246 - tail call void @putchar(i8 74) - ret void - -484: ; preds = %246 - tail call void @putchar(i8 72) - ret void - -485: ; preds = %247 - tail call void @putchar(i8 70) - ret void - -486: ; preds = %247 - tail call void @putchar(i8 68) - ret void - -487: ; preds = %248 - tail call void @putchar(i8 66) - ret void - -488: ; preds = %248 - tail call void @putchar(i8 64) - ret void - -489: ; preds = %249 - tail call void @putchar(i8 62) - ret void - -490: ; preds = %249 - tail call void @putchar(i8 60) - ret void - -491: ; preds = %250 - tail call void @putchar(i8 58) - ret void - -492: ; preds = %250 - tail call void @putchar(i8 56) - ret void - -493: ; preds = %251 - tail call void @putchar(i8 54) - ret void - -494: ; preds = %251 - tail call void @putchar(i8 52) - ret void - -495: ; preds = %252 - tail call void @putchar(i8 50) - ret void - -496: ; preds = %252 - tail call void @putchar(i8 48) - ret void - -497: ; preds = %253 - tail call void @putchar(i8 46) - ret void - -498: ; preds = %253 - tail call void @putchar(i8 44) - ret void - -499: ; preds = %254 - tail call void @putchar(i8 42) - ret void - -500: ; preds = %254 - tail call void @putchar(i8 40) - ret void - -501: ; preds = %255 - tail call void @putchar(i8 38) - ret void - -502: ; preds = %255 - tail call void @putchar(i8 36) - ret void - -503: ; preds = %256 - tail call void @putchar(i8 34) - ret void - -504: ; preds = %256 - tail call void @putchar(i8 32) - ret void - -505: ; preds = %257 - tail call void @putchar(i8 30) - ret void - -506: ; preds = %257 - tail call void @putchar(i8 28) - ret void - -507: ; preds = %258 - tail call void @putchar(i8 26) - ret void - -508: ; preds = %258 - tail call void @putchar(i8 24) - ret void - -509: ; preds = %259 - tail call void @putchar(i8 22) - ret void - -510: ; preds = %259 - tail call void @putchar(i8 20) - ret void - -511: ; preds = %260 - tail call void @putchar(i8 18) - ret void - -512: ; preds = %260 - tail call void @putchar(i8 16) - ret void - -513: ; preds = %261 - tail call void @putchar(i8 14) - ret void - -514: ; preds = %261 - tail call void @putchar(i8 12) - ret void - -515: ; preds = %262 - tail call void @putchar(i8 10) - ret void - -516: ; preds = %262 - tail call void @putchar(i8 8) - ret void - -517: ; preds = %263 - tail call void @putchar(i8 6) - ret void - -518: ; preds = %263 - tail call void @putchar(i8 4) - ret void - -519: ; preds = %264 - tail call void @putchar(i8 2) - ret void - -520: ; preds = %264 - tail call void @putchar(i8 0) - ret void -} - define void @main() local_unnamed_addr { %1 = tail call i8 @getchar() %2 = icmp sgt i8 %1, -1 @@ -1871,60 +13,854 @@ define void @main() local_unnamed_addr { %4 = icmp eq i8 %3, 0 %5 = and i8 %1, 32 %6 = icmp eq i8 %5, 0 - br i1 %2, label %12, label %7 - -7: ; preds = %0 - br i1 %4, label %10, label %8 - -8: ; preds = %7 - br i1 %6, label %9, label %codeRepl.i.i - -codeRepl.i.i: ; preds = %8 - tail call fastcc void @__elem_2(i1 true, i8 %1, i1 true, i1 true) - br label %__elem_0.exit - -9: ; preds = %8 - tail call fastcc void @__elem_2(i1 false, i8 %1, i1 true, i1 true) - br label %__elem_0.exit - -10: ; preds = %7 - br i1 %6, label %11, label %codeRepl.i1.i - -codeRepl.i1.i: ; preds = %10 - tail call fastcc void @__elem_2(i1 true, i8 %1, i1 true, i1 false) - br label %__elem_0.exit - -11: ; preds = %10 - tail call fastcc void @__elem_2(i1 false, i8 %1, i1 true, i1 false) - br label %__elem_0.exit - -__elem_0.exit: ; preds = %codeRepl.i1.i3, %16, %codeRepl.i.i1, %14, %codeRepl.i1.i, %11, %codeRepl.i.i, %9 - ret void - -12: ; preds = %0 - br i1 %4, label %15, label %13 - -13: ; preds = %12 - br i1 %6, label %14, label %codeRepl.i.i1 - -codeRepl.i.i1: ; preds = %13 - tail call fastcc void @__elem_2(i1 true, i8 %1, i1 false, i1 true) - br label %__elem_0.exit + %7 = and i8 %1, 16 + %8 = icmp eq i8 %7, 0 + br i1 %2, label %231, label %9 -14: ; preds = %13 - tail call fastcc void @__elem_2(i1 false, i8 %1, i1 false, i1 true) - br label %__elem_0.exit +9: ; preds = %0 + br i1 %4, label %122, label %codeRepl.i -15: ; preds = %12 - br i1 %6, label %16, label %codeRepl.i1.i3 +codeRepl.i: ; preds = %9 + br i1 %6, label %67, label %10 + +10: ; preds = %codeRepl.i + br i1 %8, label %39, label %codeRepl.i.i + +codeRepl.i.i: ; preds = %10 + %11 = and i8 %1, 8 + %12 = icmp eq i8 %11, 0 + %13 = and i8 %1, 4 + %14 = icmp eq i8 %13, 0 + %15 = and i8 %1, 2 + %16 = icmp eq i8 %15, 0 + %17 = and i8 %1, 1 + %18 = trunc i8 %17 to i3 + %19 = icmp eq i8 %17, 0 + %..i7.i = select i1 %19, i3 2, i3 3 + %.sink.i8.i = select i1 %16, i3 %18, i3 %..i7.i + br i1 %12, label %27, label %20 + +20: ; preds = %codeRepl.i.i + %21 = zext i3 %.sink.i8.i to i4 + br i1 %14, label %24, label %codeRepl.i.i12 + +codeRepl.i.i12: ; preds = %20 + %22 = or i4 %21, -4 + %23 = zext i4 %22 to i5 + br label %__elem_3.exit + +24: ; preds = %20 + %25 = or i4 %21, -8 + %26 = zext i4 %25 to i5 + br label %__elem_3.exit + +27: ; preds = %codeRepl.i.i + br i1 %14, label %30, label %codeRepl.i1.i13 + +codeRepl.i1.i13: ; preds = %27 + %28 = or i3 %.sink.i8.i, -4 + %29 = zext i3 %28 to i5 + br label %__elem_3.exit -codeRepl.i1.i3: ; preds = %15 - tail call fastcc void @__elem_2(i1 true, i8 %1, i1 false, i1 false) - br label %__elem_0.exit +30: ; preds = %27 + %31 = zext i3 %.sink.i8.i to i5 + br label %__elem_3.exit + +__elem_3.exit: ; preds = %codeRepl.i.i12, %24, %codeRepl.i1.i13, %30 + %.sink17.i = phi i5 [ %29, %codeRepl.i1.i13 ], [ %31, %30 ], [ %26, %24 ], [ %23, %codeRepl.i.i12 ] + %32 = or i5 %.sink17.i, -16 + %33 = zext i5 %32 to i6 + %34 = or i6 -32, %33 + %35 = zext i6 %34 to i7 + %36 = or i7 -64, %35 + %37 = zext i7 %36 to i8 + %38 = or i8 -128, %37 + tail call void @putchar(i8 %38) + br label %__elem_0.4.exit + +39: ; preds = %10 + %40 = and i8 %1, 8 + %41 = icmp eq i8 %40, 0 + %42 = and i8 %1, 4 + %43 = icmp eq i8 %42, 0 + %44 = and i8 %1, 2 + %45 = icmp eq i8 %44, 0 + %46 = and i8 %1, 1 + %47 = trunc i8 %46 to i3 + %48 = icmp eq i8 %46, 0 + %..i7.i14 = select i1 %48, i3 2, i3 3 + %.sink.i8.i15 = select i1 %45, i3 %47, i3 %..i7.i14 + br i1 %41, label %56, label %49 + +49: ; preds = %39 + %50 = zext i3 %.sink.i8.i15 to i4 + br i1 %43, label %53, label %codeRepl.i.i16 + +codeRepl.i.i16: ; preds = %49 + %51 = or i4 %50, -4 + %52 = zext i4 %51 to i5 + br label %__elem_3.exit19 + +53: ; preds = %49 + %54 = or i4 %50, -8 + %55 = zext i4 %54 to i5 + br label %__elem_3.exit19 + +56: ; preds = %39 + br i1 %43, label %59, label %codeRepl.i1.i18 + +codeRepl.i1.i18: ; preds = %56 + %57 = or i3 %.sink.i8.i15, -4 + %58 = zext i3 %57 to i5 + br label %__elem_3.exit19 + +59: ; preds = %56 + %60 = zext i3 %.sink.i8.i15 to i5 + br label %__elem_3.exit19 + +__elem_3.exit19: ; preds = %codeRepl.i.i16, %53, %codeRepl.i1.i18, %59 + %.sink17.i17 = phi i5 [ %58, %codeRepl.i1.i18 ], [ %60, %59 ], [ %55, %53 ], [ %52, %codeRepl.i.i16 ] + %61 = zext i5 %.sink17.i17 to i6 + %62 = or i6 -32, %61 + %63 = zext i6 %62 to i7 + %64 = or i7 -64, %63 + %65 = zext i7 %64 to i8 + %66 = or i8 -128, %65 + tail call void @putchar(i8 %66) + br label %__elem_0.4.exit + +67: ; preds = %codeRepl.i + br i1 %8, label %95, label %codeRepl.i1.i + +codeRepl.i1.i: ; preds = %67 + %68 = and i8 %1, 8 + %69 = icmp eq i8 %68, 0 + %70 = and i8 %1, 4 + %71 = icmp eq i8 %70, 0 + %72 = and i8 %1, 2 + %73 = icmp eq i8 %72, 0 + %74 = and i8 %1, 1 + %75 = trunc i8 %74 to i3 + %76 = icmp eq i8 %74, 0 + %..i7.i20 = select i1 %76, i3 2, i3 3 + %.sink.i8.i21 = select i1 %73, i3 %75, i3 %..i7.i20 + br i1 %69, label %84, label %77 + +77: ; preds = %codeRepl.i1.i + %78 = zext i3 %.sink.i8.i21 to i4 + br i1 %71, label %81, label %codeRepl.i.i22 + +codeRepl.i.i22: ; preds = %77 + %79 = or i4 %78, -4 + %80 = zext i4 %79 to i5 + br label %__elem_3.exit25 + +81: ; preds = %77 + %82 = or i4 %78, -8 + %83 = zext i4 %82 to i5 + br label %__elem_3.exit25 + +84: ; preds = %codeRepl.i1.i + br i1 %71, label %87, label %codeRepl.i1.i24 + +codeRepl.i1.i24: ; preds = %84 + %85 = or i3 %.sink.i8.i21, -4 + %86 = zext i3 %85 to i5 + br label %__elem_3.exit25 + +87: ; preds = %84 + %88 = zext i3 %.sink.i8.i21 to i5 + br label %__elem_3.exit25 + +__elem_3.exit25: ; preds = %codeRepl.i.i22, %81, %codeRepl.i1.i24, %87 + %.sink17.i23 = phi i5 [ %86, %codeRepl.i1.i24 ], [ %88, %87 ], [ %83, %81 ], [ %80, %codeRepl.i.i22 ] + %89 = or i5 %.sink17.i23, -16 + %90 = zext i5 %89 to i6 + %91 = zext i6 %90 to i7 + %92 = or i7 -64, %91 + %93 = zext i7 %92 to i8 + %94 = or i8 -128, %93 + tail call void @putchar(i8 %94) + br label %__elem_0.4.exit + +95: ; preds = %67 + %96 = and i8 %1, 8 + %97 = icmp eq i8 %96, 0 + %98 = and i8 %1, 4 + %99 = icmp eq i8 %98, 0 + %100 = and i8 %1, 2 + %101 = icmp eq i8 %100, 0 + %102 = and i8 %1, 1 + %103 = trunc i8 %102 to i3 + %104 = icmp eq i8 %102, 0 + %..i7.i26 = select i1 %104, i3 2, i3 3 + %.sink.i8.i27 = select i1 %101, i3 %103, i3 %..i7.i26 + br i1 %97, label %112, label %105 + +105: ; preds = %95 + %106 = zext i3 %.sink.i8.i27 to i4 + br i1 %99, label %109, label %codeRepl.i.i28 + +codeRepl.i.i28: ; preds = %105 + %107 = or i4 %106, -4 + %108 = zext i4 %107 to i5 + br label %__elem_3.exit31 + +109: ; preds = %105 + %110 = or i4 %106, -8 + %111 = zext i4 %110 to i5 + br label %__elem_3.exit31 + +112: ; preds = %95 + br i1 %99, label %115, label %codeRepl.i1.i30 + +codeRepl.i1.i30: ; preds = %112 + %113 = or i3 %.sink.i8.i27, -4 + %114 = zext i3 %113 to i5 + br label %__elem_3.exit31 -16: ; preds = %15 - tail call fastcc void @__elem_2(i1 false, i8 %1, i1 false, i1 false) - br label %__elem_0.exit +115: ; preds = %112 + %116 = zext i3 %.sink.i8.i27 to i5 + br label %__elem_3.exit31 + +__elem_3.exit31: ; preds = %codeRepl.i.i28, %109, %codeRepl.i1.i30, %115 + %.sink17.i29 = phi i5 [ %114, %codeRepl.i1.i30 ], [ %116, %115 ], [ %111, %109 ], [ %108, %codeRepl.i.i28 ] + %117 = zext i5 %.sink17.i29 to i6 + %118 = zext i6 %117 to i7 + %119 = or i7 -64, %118 + %120 = zext i7 %119 to i8 + %121 = or i8 -128, %120 + tail call void @putchar(i8 %121) + br label %__elem_0.4.exit + +122: ; preds = %9 + br i1 %6, label %178, label %123 + +123: ; preds = %122 + br i1 %8, label %151, label %codeRepl.i.i3 + +codeRepl.i.i3: ; preds = %123 + %124 = and i8 %1, 8 + %125 = icmp eq i8 %124, 0 + %126 = and i8 %1, 4 + %127 = icmp eq i8 %126, 0 + %128 = and i8 %1, 2 + %129 = icmp eq i8 %128, 0 + %130 = and i8 %1, 1 + %131 = trunc i8 %130 to i3 + %132 = icmp eq i8 %130, 0 + %..i7.i32 = select i1 %132, i3 2, i3 3 + %.sink.i8.i33 = select i1 %129, i3 %131, i3 %..i7.i32 + br i1 %125, label %140, label %133 + +133: ; preds = %codeRepl.i.i3 + %134 = zext i3 %.sink.i8.i33 to i4 + br i1 %127, label %137, label %codeRepl.i.i34 + +codeRepl.i.i34: ; preds = %133 + %135 = or i4 %134, -4 + %136 = zext i4 %135 to i5 + br label %__elem_3.exit37 + +137: ; preds = %133 + %138 = or i4 %134, -8 + %139 = zext i4 %138 to i5 + br label %__elem_3.exit37 + +140: ; preds = %codeRepl.i.i3 + br i1 %127, label %143, label %codeRepl.i1.i36 + +codeRepl.i1.i36: ; preds = %140 + %141 = or i3 %.sink.i8.i33, -4 + %142 = zext i3 %141 to i5 + br label %__elem_3.exit37 + +143: ; preds = %140 + %144 = zext i3 %.sink.i8.i33 to i5 + br label %__elem_3.exit37 + +__elem_3.exit37: ; preds = %codeRepl.i.i34, %137, %codeRepl.i1.i36, %143 + %.sink17.i35 = phi i5 [ %142, %codeRepl.i1.i36 ], [ %144, %143 ], [ %139, %137 ], [ %136, %codeRepl.i.i34 ] + %145 = or i5 %.sink17.i35, -16 + %146 = zext i5 %145 to i6 + %147 = or i6 -32, %146 + %148 = zext i6 %147 to i7 + %149 = zext i7 %148 to i8 + %150 = or i8 -128, %149 + tail call void @putchar(i8 %150) + br label %__elem_0.4.exit + +151: ; preds = %123 + %152 = and i8 %1, 8 + %153 = icmp eq i8 %152, 0 + %154 = and i8 %1, 4 + %155 = icmp eq i8 %154, 0 + %156 = and i8 %1, 2 + %157 = icmp eq i8 %156, 0 + %158 = and i8 %1, 1 + %159 = trunc i8 %158 to i3 + %160 = icmp eq i8 %158, 0 + %..i7.i38 = select i1 %160, i3 2, i3 3 + %.sink.i8.i39 = select i1 %157, i3 %159, i3 %..i7.i38 + br i1 %153, label %168, label %161 + +161: ; preds = %151 + %162 = zext i3 %.sink.i8.i39 to i4 + br i1 %155, label %165, label %codeRepl.i.i40 + +codeRepl.i.i40: ; preds = %161 + %163 = or i4 %162, -4 + %164 = zext i4 %163 to i5 + br label %__elem_3.exit43 + +165: ; preds = %161 + %166 = or i4 %162, -8 + %167 = zext i4 %166 to i5 + br label %__elem_3.exit43 + +168: ; preds = %151 + br i1 %155, label %171, label %codeRepl.i1.i42 + +codeRepl.i1.i42: ; preds = %168 + %169 = or i3 %.sink.i8.i39, -4 + %170 = zext i3 %169 to i5 + br label %__elem_3.exit43 + +171: ; preds = %168 + %172 = zext i3 %.sink.i8.i39 to i5 + br label %__elem_3.exit43 + +__elem_3.exit43: ; preds = %codeRepl.i.i40, %165, %codeRepl.i1.i42, %171 + %.sink17.i41 = phi i5 [ %170, %codeRepl.i1.i42 ], [ %172, %171 ], [ %167, %165 ], [ %164, %codeRepl.i.i40 ] + %173 = zext i5 %.sink17.i41 to i6 + %174 = or i6 -32, %173 + %175 = zext i6 %174 to i7 + %176 = zext i7 %175 to i8 + %177 = or i8 -128, %176 + tail call void @putchar(i8 %177) + br label %__elem_0.4.exit + +178: ; preds = %122 + br i1 %8, label %205, label %codeRepl.i1.i4 + +codeRepl.i1.i4: ; preds = %178 + %179 = and i8 %1, 8 + %180 = icmp eq i8 %179, 0 + %181 = and i8 %1, 4 + %182 = icmp eq i8 %181, 0 + %183 = and i8 %1, 2 + %184 = icmp eq i8 %183, 0 + %185 = and i8 %1, 1 + %186 = trunc i8 %185 to i3 + %187 = icmp eq i8 %185, 0 + %..i7.i44 = select i1 %187, i3 2, i3 3 + %.sink.i8.i45 = select i1 %184, i3 %186, i3 %..i7.i44 + br i1 %180, label %195, label %188 + +188: ; preds = %codeRepl.i1.i4 + %189 = zext i3 %.sink.i8.i45 to i4 + br i1 %182, label %192, label %codeRepl.i.i46 + +codeRepl.i.i46: ; preds = %188 + %190 = or i4 %189, -4 + %191 = zext i4 %190 to i5 + br label %__elem_3.exit49 + +192: ; preds = %188 + %193 = or i4 %189, -8 + %194 = zext i4 %193 to i5 + br label %__elem_3.exit49 + +195: ; preds = %codeRepl.i1.i4 + br i1 %182, label %198, label %codeRepl.i1.i48 + +codeRepl.i1.i48: ; preds = %195 + %196 = or i3 %.sink.i8.i45, -4 + %197 = zext i3 %196 to i5 + br label %__elem_3.exit49 + +198: ; preds = %195 + %199 = zext i3 %.sink.i8.i45 to i5 + br label %__elem_3.exit49 + +__elem_3.exit49: ; preds = %codeRepl.i.i46, %192, %codeRepl.i1.i48, %198 + %.sink17.i47 = phi i5 [ %197, %codeRepl.i1.i48 ], [ %199, %198 ], [ %194, %192 ], [ %191, %codeRepl.i.i46 ] + %200 = or i5 %.sink17.i47, -16 + %201 = zext i5 %200 to i6 + %202 = zext i6 %201 to i7 + %203 = zext i7 %202 to i8 + %204 = or i8 -128, %203 + tail call void @putchar(i8 %204) + br label %__elem_0.4.exit + +205: ; preds = %178 + %206 = and i8 %1, 8 + %207 = icmp eq i8 %206, 0 + %208 = and i8 %1, 4 + %209 = icmp eq i8 %208, 0 + %210 = and i8 %1, 2 + %211 = icmp eq i8 %210, 0 + %212 = and i8 %1, 1 + %213 = trunc i8 %212 to i3 + %214 = icmp eq i8 %212, 0 + %..i7.i50 = select i1 %214, i3 2, i3 3 + %.sink.i8.i51 = select i1 %211, i3 %213, i3 %..i7.i50 + br i1 %207, label %222, label %215 + +215: ; preds = %205 + %216 = zext i3 %.sink.i8.i51 to i4 + br i1 %209, label %219, label %codeRepl.i.i52 + +codeRepl.i.i52: ; preds = %215 + %217 = or i4 %216, -4 + %218 = zext i4 %217 to i5 + br label %__elem_3.exit55 + +219: ; preds = %215 + %220 = or i4 %216, -8 + %221 = zext i4 %220 to i5 + br label %__elem_3.exit55 + +222: ; preds = %205 + br i1 %209, label %225, label %codeRepl.i1.i54 + +codeRepl.i1.i54: ; preds = %222 + %223 = or i3 %.sink.i8.i51, -4 + %224 = zext i3 %223 to i5 + br label %__elem_3.exit55 + +225: ; preds = %222 + %226 = zext i3 %.sink.i8.i51 to i5 + br label %__elem_3.exit55 + +__elem_3.exit55: ; preds = %codeRepl.i.i52, %219, %codeRepl.i1.i54, %225 + %.sink17.i53 = phi i5 [ %224, %codeRepl.i1.i54 ], [ %226, %225 ], [ %221, %219 ], [ %218, %codeRepl.i.i52 ] + %227 = zext i5 %.sink17.i53 to i6 + %228 = zext i6 %227 to i7 + %229 = zext i7 %228 to i8 + %230 = or i8 -128, %229 + tail call void @putchar(i8 %230) + br label %__elem_0.4.exit + +__elem_0.4.exit: ; preds = %__elem_3.exit103, %__elem_3.exit97, %__elem_3.exit91, %__elem_3.exit85, %__elem_3.exit79, %__elem_3.exit73, %__elem_3.exit67, %__elem_3.exit61, %__elem_3.exit55, %__elem_3.exit49, %__elem_3.exit43, %__elem_3.exit37, %__elem_3.exit31, %__elem_3.exit25, %__elem_3.exit19, %__elem_3.exit + ret void + +231: ; preds = %0 + br i1 %4, label %340, label %codeRepl.i1 + +codeRepl.i1: ; preds = %231 + br i1 %6, label %287, label %232 + +232: ; preds = %codeRepl.i1 + br i1 %8, label %260, label %codeRepl.i.i6 + +codeRepl.i.i6: ; preds = %232 + %233 = and i8 %1, 8 + %234 = icmp eq i8 %233, 0 + %235 = and i8 %1, 4 + %236 = icmp eq i8 %235, 0 + %237 = and i8 %1, 2 + %238 = icmp eq i8 %237, 0 + %239 = and i8 %1, 1 + %240 = trunc i8 %239 to i3 + %241 = icmp eq i8 %239, 0 + %..i7.i56 = select i1 %241, i3 2, i3 3 + %.sink.i8.i57 = select i1 %238, i3 %240, i3 %..i7.i56 + br i1 %234, label %249, label %242 + +242: ; preds = %codeRepl.i.i6 + %243 = zext i3 %.sink.i8.i57 to i4 + br i1 %236, label %246, label %codeRepl.i.i58 + +codeRepl.i.i58: ; preds = %242 + %244 = or i4 %243, -4 + %245 = zext i4 %244 to i5 + br label %__elem_3.exit61 + +246: ; preds = %242 + %247 = or i4 %243, -8 + %248 = zext i4 %247 to i5 + br label %__elem_3.exit61 + +249: ; preds = %codeRepl.i.i6 + br i1 %236, label %252, label %codeRepl.i1.i60 + +codeRepl.i1.i60: ; preds = %249 + %250 = or i3 %.sink.i8.i57, -4 + %251 = zext i3 %250 to i5 + br label %__elem_3.exit61 + +252: ; preds = %249 + %253 = zext i3 %.sink.i8.i57 to i5 + br label %__elem_3.exit61 + +__elem_3.exit61: ; preds = %codeRepl.i.i58, %246, %codeRepl.i1.i60, %252 + %.sink17.i59 = phi i5 [ %251, %codeRepl.i1.i60 ], [ %253, %252 ], [ %248, %246 ], [ %245, %codeRepl.i.i58 ] + %254 = or i5 %.sink17.i59, -16 + %255 = zext i5 %254 to i6 + %256 = or i6 -32, %255 + %257 = zext i6 %256 to i7 + %258 = or i7 -64, %257 + %259 = zext i7 %258 to i8 + tail call void @putchar(i8 %259) + br label %__elem_0.4.exit + +260: ; preds = %232 + %261 = and i8 %1, 8 + %262 = icmp eq i8 %261, 0 + %263 = and i8 %1, 4 + %264 = icmp eq i8 %263, 0 + %265 = and i8 %1, 2 + %266 = icmp eq i8 %265, 0 + %267 = and i8 %1, 1 + %268 = trunc i8 %267 to i3 + %269 = icmp eq i8 %267, 0 + %..i7.i62 = select i1 %269, i3 2, i3 3 + %.sink.i8.i63 = select i1 %266, i3 %268, i3 %..i7.i62 + br i1 %262, label %277, label %270 + +270: ; preds = %260 + %271 = zext i3 %.sink.i8.i63 to i4 + br i1 %264, label %274, label %codeRepl.i.i64 + +codeRepl.i.i64: ; preds = %270 + %272 = or i4 %271, -4 + %273 = zext i4 %272 to i5 + br label %__elem_3.exit67 + +274: ; preds = %270 + %275 = or i4 %271, -8 + %276 = zext i4 %275 to i5 + br label %__elem_3.exit67 + +277: ; preds = %260 + br i1 %264, label %280, label %codeRepl.i1.i66 + +codeRepl.i1.i66: ; preds = %277 + %278 = or i3 %.sink.i8.i63, -4 + %279 = zext i3 %278 to i5 + br label %__elem_3.exit67 + +280: ; preds = %277 + %281 = zext i3 %.sink.i8.i63 to i5 + br label %__elem_3.exit67 + +__elem_3.exit67: ; preds = %codeRepl.i.i64, %274, %codeRepl.i1.i66, %280 + %.sink17.i65 = phi i5 [ %279, %codeRepl.i1.i66 ], [ %281, %280 ], [ %276, %274 ], [ %273, %codeRepl.i.i64 ] + %282 = zext i5 %.sink17.i65 to i6 + %283 = or i6 -32, %282 + %284 = zext i6 %283 to i7 + %285 = or i7 -64, %284 + %286 = zext i7 %285 to i8 + tail call void @putchar(i8 %286) + br label %__elem_0.4.exit + +287: ; preds = %codeRepl.i1 + br i1 %8, label %314, label %codeRepl.i1.i7 + +codeRepl.i1.i7: ; preds = %287 + %288 = and i8 %1, 8 + %289 = icmp eq i8 %288, 0 + %290 = and i8 %1, 4 + %291 = icmp eq i8 %290, 0 + %292 = and i8 %1, 2 + %293 = icmp eq i8 %292, 0 + %294 = and i8 %1, 1 + %295 = trunc i8 %294 to i3 + %296 = icmp eq i8 %294, 0 + %..i7.i68 = select i1 %296, i3 2, i3 3 + %.sink.i8.i69 = select i1 %293, i3 %295, i3 %..i7.i68 + br i1 %289, label %304, label %297 + +297: ; preds = %codeRepl.i1.i7 + %298 = zext i3 %.sink.i8.i69 to i4 + br i1 %291, label %301, label %codeRepl.i.i70 + +codeRepl.i.i70: ; preds = %297 + %299 = or i4 %298, -4 + %300 = zext i4 %299 to i5 + br label %__elem_3.exit73 + +301: ; preds = %297 + %302 = or i4 %298, -8 + %303 = zext i4 %302 to i5 + br label %__elem_3.exit73 + +304: ; preds = %codeRepl.i1.i7 + br i1 %291, label %307, label %codeRepl.i1.i72 + +codeRepl.i1.i72: ; preds = %304 + %305 = or i3 %.sink.i8.i69, -4 + %306 = zext i3 %305 to i5 + br label %__elem_3.exit73 + +307: ; preds = %304 + %308 = zext i3 %.sink.i8.i69 to i5 + br label %__elem_3.exit73 + +__elem_3.exit73: ; preds = %codeRepl.i.i70, %301, %codeRepl.i1.i72, %307 + %.sink17.i71 = phi i5 [ %306, %codeRepl.i1.i72 ], [ %308, %307 ], [ %303, %301 ], [ %300, %codeRepl.i.i70 ] + %309 = or i5 %.sink17.i71, -16 + %310 = zext i5 %309 to i6 + %311 = zext i6 %310 to i7 + %312 = or i7 -64, %311 + %313 = zext i7 %312 to i8 + tail call void @putchar(i8 %313) + br label %__elem_0.4.exit + +314: ; preds = %287 + %315 = and i8 %1, 8 + %316 = icmp eq i8 %315, 0 + %317 = and i8 %1, 4 + %318 = icmp eq i8 %317, 0 + %319 = and i8 %1, 2 + %320 = icmp eq i8 %319, 0 + %321 = and i8 %1, 1 + %322 = trunc i8 %321 to i3 + %323 = icmp eq i8 %321, 0 + %..i7.i74 = select i1 %323, i3 2, i3 3 + %.sink.i8.i75 = select i1 %320, i3 %322, i3 %..i7.i74 + br i1 %316, label %331, label %324 + +324: ; preds = %314 + %325 = zext i3 %.sink.i8.i75 to i4 + br i1 %318, label %328, label %codeRepl.i.i76 + +codeRepl.i.i76: ; preds = %324 + %326 = or i4 %325, -4 + %327 = zext i4 %326 to i5 + br label %__elem_3.exit79 + +328: ; preds = %324 + %329 = or i4 %325, -8 + %330 = zext i4 %329 to i5 + br label %__elem_3.exit79 + +331: ; preds = %314 + br i1 %318, label %334, label %codeRepl.i1.i78 + +codeRepl.i1.i78: ; preds = %331 + %332 = or i3 %.sink.i8.i75, -4 + %333 = zext i3 %332 to i5 + br label %__elem_3.exit79 + +334: ; preds = %331 + %335 = zext i3 %.sink.i8.i75 to i5 + br label %__elem_3.exit79 + +__elem_3.exit79: ; preds = %codeRepl.i.i76, %328, %codeRepl.i1.i78, %334 + %.sink17.i77 = phi i5 [ %333, %codeRepl.i1.i78 ], [ %335, %334 ], [ %330, %328 ], [ %327, %codeRepl.i.i76 ] + %336 = zext i5 %.sink17.i77 to i6 + %337 = zext i6 %336 to i7 + %338 = or i7 -64, %337 + %339 = zext i7 %338 to i8 + tail call void @putchar(i8 %339) + br label %__elem_0.4.exit + +340: ; preds = %231 + br i1 %6, label %394, label %341 + +341: ; preds = %340 + br i1 %8, label %368, label %codeRepl.i.i9 + +codeRepl.i.i9: ; preds = %341 + %342 = and i8 %1, 8 + %343 = icmp eq i8 %342, 0 + %344 = and i8 %1, 4 + %345 = icmp eq i8 %344, 0 + %346 = and i8 %1, 2 + %347 = icmp eq i8 %346, 0 + %348 = and i8 %1, 1 + %349 = trunc i8 %348 to i3 + %350 = icmp eq i8 %348, 0 + %..i7.i80 = select i1 %350, i3 2, i3 3 + %.sink.i8.i81 = select i1 %347, i3 %349, i3 %..i7.i80 + br i1 %343, label %358, label %351 + +351: ; preds = %codeRepl.i.i9 + %352 = zext i3 %.sink.i8.i81 to i4 + br i1 %345, label %355, label %codeRepl.i.i82 + +codeRepl.i.i82: ; preds = %351 + %353 = or i4 %352, -4 + %354 = zext i4 %353 to i5 + br label %__elem_3.exit85 + +355: ; preds = %351 + %356 = or i4 %352, -8 + %357 = zext i4 %356 to i5 + br label %__elem_3.exit85 + +358: ; preds = %codeRepl.i.i9 + br i1 %345, label %361, label %codeRepl.i1.i84 + +codeRepl.i1.i84: ; preds = %358 + %359 = or i3 %.sink.i8.i81, -4 + %360 = zext i3 %359 to i5 + br label %__elem_3.exit85 + +361: ; preds = %358 + %362 = zext i3 %.sink.i8.i81 to i5 + br label %__elem_3.exit85 + +__elem_3.exit85: ; preds = %codeRepl.i.i82, %355, %codeRepl.i1.i84, %361 + %.sink17.i83 = phi i5 [ %360, %codeRepl.i1.i84 ], [ %362, %361 ], [ %357, %355 ], [ %354, %codeRepl.i.i82 ] + %363 = or i5 %.sink17.i83, -16 + %364 = zext i5 %363 to i6 + %365 = or i6 -32, %364 + %366 = zext i6 %365 to i7 + %367 = zext i7 %366 to i8 + tail call void @putchar(i8 %367) + br label %__elem_0.4.exit + +368: ; preds = %341 + %369 = and i8 %1, 8 + %370 = icmp eq i8 %369, 0 + %371 = and i8 %1, 4 + %372 = icmp eq i8 %371, 0 + %373 = and i8 %1, 2 + %374 = icmp eq i8 %373, 0 + %375 = and i8 %1, 1 + %376 = trunc i8 %375 to i3 + %377 = icmp eq i8 %375, 0 + %..i7.i86 = select i1 %377, i3 2, i3 3 + %.sink.i8.i87 = select i1 %374, i3 %376, i3 %..i7.i86 + br i1 %370, label %385, label %378 + +378: ; preds = %368 + %379 = zext i3 %.sink.i8.i87 to i4 + br i1 %372, label %382, label %codeRepl.i.i88 + +codeRepl.i.i88: ; preds = %378 + %380 = or i4 %379, -4 + %381 = zext i4 %380 to i5 + br label %__elem_3.exit91 + +382: ; preds = %378 + %383 = or i4 %379, -8 + %384 = zext i4 %383 to i5 + br label %__elem_3.exit91 + +385: ; preds = %368 + br i1 %372, label %388, label %codeRepl.i1.i90 + +codeRepl.i1.i90: ; preds = %385 + %386 = or i3 %.sink.i8.i87, -4 + %387 = zext i3 %386 to i5 + br label %__elem_3.exit91 + +388: ; preds = %385 + %389 = zext i3 %.sink.i8.i87 to i5 + br label %__elem_3.exit91 + +__elem_3.exit91: ; preds = %codeRepl.i.i88, %382, %codeRepl.i1.i90, %388 + %.sink17.i89 = phi i5 [ %387, %codeRepl.i1.i90 ], [ %389, %388 ], [ %384, %382 ], [ %381, %codeRepl.i.i88 ] + %390 = zext i5 %.sink17.i89 to i6 + %391 = or i6 -32, %390 + %392 = zext i6 %391 to i7 + %393 = zext i7 %392 to i8 + tail call void @putchar(i8 %393) + br label %__elem_0.4.exit + +394: ; preds = %340 + br i1 %8, label %420, label %codeRepl.i1.i10 + +codeRepl.i1.i10: ; preds = %394 + %395 = and i8 %1, 8 + %396 = icmp eq i8 %395, 0 + %397 = and i8 %1, 4 + %398 = icmp eq i8 %397, 0 + %399 = and i8 %1, 2 + %400 = icmp eq i8 %399, 0 + %401 = and i8 %1, 1 + %402 = trunc i8 %401 to i3 + %403 = icmp eq i8 %401, 0 + %..i7.i92 = select i1 %403, i3 2, i3 3 + %.sink.i8.i93 = select i1 %400, i3 %402, i3 %..i7.i92 + br i1 %396, label %411, label %404 + +404: ; preds = %codeRepl.i1.i10 + %405 = zext i3 %.sink.i8.i93 to i4 + br i1 %398, label %408, label %codeRepl.i.i94 + +codeRepl.i.i94: ; preds = %404 + %406 = or i4 %405, -4 + %407 = zext i4 %406 to i5 + br label %__elem_3.exit97 + +408: ; preds = %404 + %409 = or i4 %405, -8 + %410 = zext i4 %409 to i5 + br label %__elem_3.exit97 + +411: ; preds = %codeRepl.i1.i10 + br i1 %398, label %414, label %codeRepl.i1.i96 + +codeRepl.i1.i96: ; preds = %411 + %412 = or i3 %.sink.i8.i93, -4 + %413 = zext i3 %412 to i5 + br label %__elem_3.exit97 + +414: ; preds = %411 + %415 = zext i3 %.sink.i8.i93 to i5 + br label %__elem_3.exit97 + +__elem_3.exit97: ; preds = %codeRepl.i.i94, %408, %codeRepl.i1.i96, %414 + %.sink17.i95 = phi i5 [ %413, %codeRepl.i1.i96 ], [ %415, %414 ], [ %410, %408 ], [ %407, %codeRepl.i.i94 ] + %416 = or i5 %.sink17.i95, -16 + %417 = zext i5 %416 to i6 + %418 = zext i6 %417 to i7 + %419 = zext i7 %418 to i8 + tail call void @putchar(i8 %419) + br label %__elem_0.4.exit + +420: ; preds = %394 + %421 = and i8 %1, 8 + %422 = icmp eq i8 %421, 0 + %423 = and i8 %1, 4 + %424 = icmp eq i8 %423, 0 + %425 = and i8 %1, 2 + %426 = icmp eq i8 %425, 0 + %427 = and i8 %1, 1 + %428 = trunc i8 %427 to i3 + %429 = icmp eq i8 %427, 0 + %..i7.i98 = select i1 %429, i3 2, i3 3 + %.sink.i8.i99 = select i1 %426, i3 %428, i3 %..i7.i98 + br i1 %422, label %437, label %430 + +430: ; preds = %420 + %431 = zext i3 %.sink.i8.i99 to i4 + br i1 %424, label %434, label %codeRepl.i.i100 + +codeRepl.i.i100: ; preds = %430 + %432 = or i4 %431, -4 + %433 = zext i4 %432 to i5 + br label %__elem_3.exit103 + +434: ; preds = %430 + %435 = or i4 %431, -8 + %436 = zext i4 %435 to i5 + br label %__elem_3.exit103 + +437: ; preds = %420 + br i1 %424, label %440, label %codeRepl.i1.i102 + +codeRepl.i1.i102: ; preds = %437 + %438 = or i3 %.sink.i8.i99, -4 + %439 = zext i3 %438 to i5 + br label %__elem_3.exit103 + +440: ; preds = %437 + %441 = zext i3 %.sink.i8.i99 to i5 + br label %__elem_3.exit103 + +__elem_3.exit103: ; preds = %codeRepl.i.i100, %434, %codeRepl.i1.i102, %440 + %.sink17.i101 = phi i5 [ %439, %codeRepl.i1.i102 ], [ %441, %440 ], [ %436, %434 ], [ %433, %codeRepl.i.i100 ] + %442 = zext i5 %.sink17.i101 to i6 + %443 = zext i6 %442 to i7 + %444 = zext i7 %443 to i8 + tail call void @putchar(i8 %444) + br label %__elem_0.4.exit } attributes #0 = { nofree nounwind } diff --git a/test/Golden/ShareBindCont.opt.ll b/test/Golden/ShareBindCont.opt.ll index 1c68674..0be4870 100644 --- a/test/Golden/ShareBindCont.opt.ll +++ b/test/Golden/ShareBindCont.opt.ll @@ -4,12 +4,14 @@ source_filename = "test/Golden/ShareBindCont.elem" declare i1 @getbit() local_unnamed_addr define i1 @main1() local_unnamed_addr { - %1 = tail call i1 @getbit() - ret i1 %1 +__elem_0.exit: + %0 = tail call i1 @getbit() + ret i1 %0 } define i1 @main2() local_unnamed_addr { - %1 = tail call i1 @getbit() - %not.1.i = xor i1 %1, true - ret i1 %not.1.i +__elem_0.exit: + %0 = tail call i1 @getbit() + %not. = xor i1 %0, true + ret i1 %not. } diff --git a/test/Golden/ShareIO.opt.ll b/test/Golden/ShareIO.opt.ll index d0ba9be..cfb2aff 100644 --- a/test/Golden/ShareIO.opt.ll +++ b/test/Golden/ShareIO.opt.ll @@ -6,7 +6,7 @@ declare void @putbit(i1) local_unnamed_addr declare i1 @getbit() local_unnamed_addr define void @main1() local_unnamed_addr { -__elem_0.exit: +__elem_2.exit: %0 = tail call i1 @getbit() %1 = tail call i1 @getbit() %.sink = xor i1 %0, %1 @@ -15,7 +15,7 @@ __elem_0.exit: } define void @main2() local_unnamed_addr { -__elem_0.exit: +__elem_2.exit: %0 = tail call i1 @getbit() %1 = tail call i1 @getbit() %.sink = xor i1 %0, %1 diff --git a/test/Main.hs b/test/Main.hs index d88162f..adf62f6 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -27,5 +27,5 @@ tests = do ] where timeout :: Timeout - timeout = mkTimeout 120000000 -- 120s + timeout = mkTimeout $ 3600 * 1000000 -- 1 hour From 1915f7b2aa0c0172e1ad65e7911d8254eecd6c79 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Fri, 24 Jun 2022 13:40:15 +0100 Subject: [PATCH 10/17] Simplify the rewrite rules Remove the Branch0 node and inline its rules into where it was previously used. --- src/Language/Elemental/Emit.hs | 23 +++++++++- src/Language/Elemental/InteractionNet.hs | 56 +----------------------- test/Golden.hs | 4 +- 3 files changed, 24 insertions(+), 59 deletions(-) diff --git a/src/Language/Elemental/Emit.hs b/src/Language/Elemental/Emit.hs index 8139084..5749d26 100644 --- a/src/Language/Elemental/Emit.hs +++ b/src/Language/Elemental/Emit.hs @@ -216,7 +216,28 @@ emitExpr scope rr = \case let opp = Backend.Partial (SSucc $ SSucc SZero) $ Backend.InsertBit size size = fromIntegral $ toNatural ssize propagate1 rr $ OperandANode opp - TestBit -> mkLambda rr Branch0Node + TestBit -> do + rn1 <- newNode $ LamNode () () () + rn2 <- newNode $ DupNode 0 () () () + rn3 <- newNode $ AppNode () () () + rn4 <- newNode $ AppNode () () () + r5 <- mkChurchBool const + r6 <- mkChurchBool $ const id + rn7 <- newNode $ Branch0CNode () () () () + rn8 <- newNode $ LamNode () () () + rn9 <- newNode $ IOPureNode () () + linkNodes (Ref rn1 0) (Ref rn9 1) + linkNodes (Ref rn1 1) (Ref rn2 0) + linkNodes (Ref rn1 2) (Ref rn7 0) + linkNodes (Ref rn2 1) (Ref rn3 0) + linkNodes (Ref rn2 2) (Ref rn4 0) + linkNodes (Ref rn3 2) (Ref rn7 2) + linkNodes (Ref rn4 2) (Ref rn7 3) + linkNodes (Ref rn8 1) (Ref rn7 1) + linkNodes (Ref rn8 2) (Ref rn9 0) + linkNodes r5 $ Ref rn3 1 + linkNodes r6 $ Ref rn4 1 + linkNodes rr $ Ref rn8 0 where coerceScope :: SList (Const a) as -> SList (Const a) (IncrementAll 'Zero as) coerceScope SNil = SNil diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 02db5ff..2c1cbf0 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -48,6 +48,7 @@ module Language.Elemental.InteractionNet , propagate1 , propagate2 , mkLambda + , mkChurchBool , newNode , newName , newLabel @@ -211,8 +212,6 @@ data INetF a | Bind1CNode a a a -- | (B, B) | Bind1FNode (B.Named B.Instruction) a a - -- | (i1, IO (a -> a -> a)) - | Branch0Node a a -- | (B, i{n}, B, B) | Branch0CNode a a a a -- | (i{n}, B, B, B) @@ -284,7 +283,6 @@ instance Pretty a => Pretty (INetF a) where = "Bind1C" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (Bind1FNode instr r0 r1) = "Bind1F" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty instr) - pretty (Branch0Node r0 r1) = "Branch0" <+> pretty r0 <+> pretty r1 pretty (Branch0CNode r0 r1 r2 r3) = "Branch0C" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 pretty (Branch0FNode r0 r1 r2 r3) @@ -577,50 +575,6 @@ reduceNode (Bind0FNode name _ r0) (IOContNode instr _) = do linkNodes (Ref rn4 1) (Ref rn5 0) linkNodes r0 $ Ref rn2 0 reduceNode n0@IOContNode {} n1@Bind0FNode {} = reduceNode n1 n0 -reduceNode (Branch0Node _ r0) (OperandNode op _) = do - rn1 <- newNode $ LamNode () () () - rn2 <- newNode $ DupNode 0 () () () - rn3 <- newNode $ AppNode () () () - rn4 <- newNode $ AppNode () () () - r5 <- mkChurchBool const - r6 <- mkChurchBool $ const id - rn7 <- newNode $ Branch1Node op () () () - rn9 <- newNode $ IOPureNode () () - linkNodes (Ref rn1 0) (Ref rn9 1) - linkNodes (Ref rn1 1) (Ref rn2 0) - linkNodes (Ref rn1 2) (Ref rn7 0) - linkNodes (Ref rn2 1) (Ref rn3 0) - linkNodes (Ref rn2 2) (Ref rn4 0) - linkNodes (Ref rn3 2) (Ref rn7 1) - linkNodes (Ref rn4 2) (Ref rn7 2) - linkNodes r0 $ Ref rn9 0 - linkNodes r5 $ Ref rn3 1 - linkNodes r6 $ Ref rn4 1 -reduceNode n0@OperandNode {} n1@Branch0Node {} = reduceNode n1 n0 -reduceNode (Branch0Node _ r0) (PArgumentNode _ r1 r2) = do - rn1 <- newNode $ LamNode () () () - rn2 <- newNode $ DupNode 0 () () () - rn3 <- newNode $ AppNode () () () - rn4 <- newNode $ AppNode () () () - r5 <- mkChurchBool const - r6 <- mkChurchBool $ const id - rn7 <- newNode $ Branch0CNode () () () () - rn8 <- newNode $ PArgumentNode () () () - rn9 <- newNode $ IOPureNode () () - linkNodes (Ref rn1 0) (Ref rn9 1) - linkNodes (Ref rn1 1) (Ref rn2 0) - linkNodes (Ref rn1 2) (Ref rn7 0) - linkNodes (Ref rn2 1) (Ref rn3 0) - linkNodes (Ref rn2 2) (Ref rn4 0) - linkNodes (Ref rn3 2) (Ref rn7 2) - linkNodes (Ref rn4 2) (Ref rn7 3) - linkNodes (Ref rn7 1) (Ref rn8 0) - linkNodes r0 $ Ref rn9 0 - linkNodes r1 $ Ref rn8 1 - linkNodes r2 $ Ref rn8 2 - linkNodes r5 $ Ref rn3 1 - linkNodes r6 $ Ref rn4 1 -reduceNode n0@PArgumentNode {} n1@Branch0Node {} = reduceNode n1 n0 reduceNode (Branch0FNode _ r0 r1 r2) (OperandNode op _) = do rn3 <- newNode $ Branch1Node op () () () linkNodes r0 $ Ref rn3 1 @@ -880,9 +834,6 @@ reduceNode (DupNode lvl _ r0 r1) (Bind1CNode _ r2 r3) = do linkNodes r3 $ Ref rn4 2 dedupIO lvl r0 r1 $ Ref rn4 0 reduceNode n0@Bind1CNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl _ r0 r1) (Branch0Node _ r2) - = commute1 (DupNode lvl) Branch0Node r0 r1 r2 -reduceNode n0@Branch0Node {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (Branch0CNode _ r2 r3 r4) = do rn5 <- newNode $ Branch0CNode () () () () linkNodes r2 $ Ref rn5 1 @@ -985,8 +936,6 @@ reduceNode (Bind0CNode _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@Bind0CNode {} = reduceNode n1 n0 reduceNode (Bind1FNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@Bind1FNode {} = reduceNode n1 n0 -reduceNode (Branch0Node _ r0) (DeadNode _) = propagate1 r0 DeadNode -reduceNode n0@DeadNode {} n1@Branch0Node {} = reduceNode n1 n0 reduceNode (LabelNode lbl _ r0) (DeadNode _) = propagate1 r0 $ NamedBlockNode $ B.NamedBlockList $ IM.singleton (B.unLabel lbl) $ B.Block mempty B.Unreachable @@ -1046,9 +995,6 @@ reduceNode n0@BoxNode {} n1@Bind1CNode {} = reduceNode n1 n0 reduceNode (Bind1FNode nbs _ r0) (BoxNode lvl _ r1) = commute0 (Bind1FNode nbs) (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@Bind1FNode {} = reduceNode n1 n0 -reduceNode (Branch0Node _ r0) (BoxNode lvl _ r1) - = commute0 Branch0Node (BoxNode lvl) r0 r1 -reduceNode n0@BoxNode {} n1@Branch0Node {} = reduceNode n1 n0 reduceNode (Branch0CNode _ r0 r1 r2) (BoxNode lvl _ r3) = commute2b Branch0CNode (BoxNode lvl) r0 r1 r2 r3 reduceNode n0@BoxNode {} n1@Branch0CNode {} = reduceNode n1 n0 diff --git a/test/Golden.hs b/test/Golden.hs index bb75743..acbdf18 100644 --- a/test/Golden.hs +++ b/test/Golden.hs @@ -269,7 +269,7 @@ data NodeHead | IOHead | IOAHead | IOPHead | IOPureHead | IOContHead | ReturnCHead | ReturnFHead | Bind0BHead | Bind0CHead | Bind0FHead | Bind1CHead | Bind1FHead - | Branch0Head | Branch0CHead | Branch0FHead | Branch1Head + | Branch0CHead | Branch0FHead | Branch1Head | LabelHead | NamedBlockHead | Merge0Head | Merge1Head | TBuildHead | TEntryHead | TSplitHead | TCloseHead | TLeaveHead | TMatchHead @@ -301,7 +301,6 @@ instance Pretty NodeHead where pretty Bind0FHead = "Bind0F" pretty Bind1CHead = "Bind1C" pretty Bind1FHead = "Bind1F" - pretty Branch0Head = "Branch0" pretty Branch0CHead = "Branch0C" pretty Branch0FHead = "Branch0F" pretty Branch1Head = "Branch1" @@ -344,7 +343,6 @@ nodeHead x = case x of Bind0FNode {} -> Bind0FHead Bind1CNode {} -> Bind1CHead Bind1FNode {} -> Bind1FHead - Branch0Node {} -> Branch0Head Branch0CNode {} -> Branch0CHead Branch0FNode {} -> Branch0FHead Branch1Node {} -> Branch1Head From b896bea10f64ba9f69d128845b269afb8cf5c6e7 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Fri, 24 Jun 2022 14:46:20 +0100 Subject: [PATCH 11/17] Add singleton version of ForeignType --- src/Language/Elemental/AST/Expr.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Language/Elemental/AST/Expr.hs b/src/Language/Elemental/AST/Expr.hs index 4d9c190..882c0c5 100644 --- a/src/Language/Elemental/AST/Expr.hs +++ b/src/Language/Elemental/AST/Expr.hs @@ -40,6 +40,7 @@ module Language.Elemental.AST.Expr , sAllIsOpType , HasForeignType(..) , ForeignType + , sForeignType , BuildForeignType , sBuildForeignType , MarshallableType(..) @@ -375,6 +376,11 @@ instance (MarshallableType tx, IsOpType (Marshall tx) ~ 'True -- | The foreign type corresponding to a native type. type ForeignType t = BuildForeignType (ForeignArgs t) (ForeignRet t) +-- | Singleton version of 'ForeignType'. +sForeignType + :: HasForeignType t => SType tscope t -> SType tscope (ForeignType t) +sForeignType t = sBuildForeignType (sForeignArgs t) (sForeignRet t) + {-| Builds a type from a list of argument t'BackendType' and a return t'BackendType'. From 6fa68e810018d0e158981c6644b98fba6d25c0de Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Fri, 24 Jun 2022 22:05:53 +0100 Subject: [PATCH 12/17] Reduce nets faster by avoiding needless boxing Don't rebox tunnel output or PReduce's output, as there can be no duplication there. Add the second argument to Bind0C and Bind0F, as it is always known when they are produced. Remove the redundant Branch1 node by inlining its reduction into anything that would produce it. --- src/Language/Elemental/Emit.hs | 14 +- src/Language/Elemental/InteractionNet.hs | 229 +++++++++++------------ test/Golden.hs | 4 +- test/Golden/CataStaticAccum.opt.ll | 16 +- 4 files changed, 125 insertions(+), 138 deletions(-) diff --git a/src/Language/Elemental/Emit.hs b/src/Language/Elemental/Emit.hs index 5749d26..4b8d0bb 100644 --- a/src/Language/Elemental/Emit.hs +++ b/src/Language/Elemental/Emit.hs @@ -96,16 +96,14 @@ emitDecl scopeTypes scope rr = \case bname = backendForeignName fname rn1 <- newNode $ ExternalRootNode bname bargs bret () rn2 <- newNode $ AccumIONode mempty () () - rn3 <- newNode $ Bind0CNode () () - rn4 <- newNode $ AppNode () () () - rn5 <- newNode $ LamNode () () () - rn6 <- newNode $ ReturnCNode () () + rn3 <- newNode $ Bind0CNode () () () + rn4 <- newNode $ LamNode () () () + rn5 <- newNode $ ReturnCNode () () linkNodes (Ref rn1 0) (Ref rn2 1) - linkNodes (Ref rn2 0) (Ref rn4 2) + linkNodes (Ref rn2 0) (Ref rn3 2) linkNodes (Ref rn3 1) (Ref rn4 0) - linkNodes (Ref rn4 1) (Ref rn5 0) - linkNodes (Ref rn5 1) (Ref rn6 1) - linkNodes (Ref rn5 2) (Ref rn6 0) + linkNodes (Ref rn4 1) (Ref rn5 1) + linkNodes (Ref rn4 2) (Ref rn5 0) emitExpr scope (Ref rn3 0) $ applyArgs ltret ltargs ops $ wrapExport SZero scopeTypes t expr pure mempty diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 2c1cbf0..3df6336 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -204,10 +204,10 @@ data INetF a | ReturnFNode a a -- | (IO a, (a -> IO b) -> IO b) | Bind0BNode a a - -- | (IO a, (a -> B) -> B) - | Bind0CNode a a - -- | (IO a, (a -> B) -> B) - | Bind0FNode B.Name a a + -- | (IO a, a -> B, B) + | Bind0CNode a a a + -- | (IO a, a -> B, B) + | Bind0FNode B.Name a a a -- | (B, IO a, (a -> B) -> B) | Bind1CNode a a a -- | (B, B) @@ -216,8 +216,6 @@ data INetF a | Branch0CNode a a a a -- | (i{n}, B, B, B) | Branch0FNode a a a a - -- | (B, B, B) - | Branch1Node B.Operand a a a -- | (CB, NB) | LabelNode B.Label a a -- | NB @@ -276,9 +274,10 @@ instance Pretty a => Pretty (INetF a) where pretty (ReturnCNode r0 r1) = "ReturnC" <+> pretty r0 <+> pretty r1 pretty (ReturnFNode r0 r1) = "ReturnF" <+> pretty r0 <+> pretty r1 pretty (Bind0BNode r0 r1) = "Bind0B" <+> pretty r0 <+> pretty r1 - pretty (Bind0CNode r0 r1) = "Bind0C" <+> pretty r0 <+> pretty r1 - pretty (Bind0FNode name r0 r1) - = "Bind0F" <+> pretty r0 <+> pretty r1 <+> pretty name + pretty (Bind0CNode r0 r1 r2) + = "Bind0C" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (Bind0FNode name r0 r1 r2) + = "Bind0F" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty name pretty (Bind1CNode r0 r1 r2) = "Bind1C" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (Bind1FNode instr r0 r1) @@ -287,8 +286,6 @@ instance Pretty a => Pretty (INetF a) where = "Branch0C" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 pretty (Branch0FNode r0 r1 r2 r3) = "Branch0F" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 - pretty (Branch1Node opc r0 r1 r2) - = "Branch1" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty opc pretty (LabelNode lbl r0 r1) = "Label" <+> pretty r0 <+> pretty r1 <+> pretty lbl pretty (NamedBlockNode nbs r0) @@ -474,14 +471,12 @@ reduceNode (AccumIONode ib _ r0) (ReturnCNode _ r1) = do reduceNode n0@ReturnCNode {} n1@AccumIONode {} = reduceNode n1 n0 reduceNode (AccumIONode ib _ r0) (Bind1CNode _ r1 r2) = do name <- newName - rn2 <- newNode $ AccumIONode ib () () - rn3 <- newNode $ Bind0FNode name () () - rn4 <- newNode $ AppNode () () () + rn3 <- newNode $ AccumIONode ib () () + rn4 <- newNode $ Bind0FNode name () () () rn5 <- newNode $ PReduceNode () () - linkNodes (Ref rn2 0) (Ref rn4 2) - linkNodes (Ref rn3 0) (Ref rn5 1) - linkNodes (Ref rn3 1) (Ref rn4 0) - linkNodes r0 $ Ref rn2 1 + linkNodes (Ref rn3 0) (Ref rn4 2) + linkNodes (Ref rn4 0) (Ref rn5 1) + linkNodes r0 $ Ref rn3 1 linkNodes r1 $ Ref rn5 0 linkNodes r2 $ Ref rn4 1 reduceNode n0@Bind1CNode {} n1@AccumIONode {} = reduceNode n1 n0 @@ -502,25 +497,6 @@ reduceNode (AccumIONode ib _ r0) (Branch0CNode _ r1 r2 r3) = do linkNodes r2 $ Ref rn5 1 linkNodes r3 $ Ref rn5 2 reduceNode n0@Branch0CNode {} n1@AccumIONode {} = reduceNode n1 n0 -reduceNode (AccumIONode ib _ r0) (Branch1Node opc _ r1 r2) = do - lblt <- newLabel - lblf <- newLabel - let b = B.Block (B.unIBlock ib) $ B.Branch opc lblt lblf - rn3 <- newNode $ AccumNBNode (B.BlockList b mempty) () () - rn4 <- newNode $ Merge0Node () () () - rn5 <- newNode $ LabelNode lblt () () - rn6 <- newNode $ LabelNode lblf () () - rn7 <- newNode $ AccumIONode mempty () () - rn8 <- newNode $ AccumIONode mempty () () - linkNodes (Ref rn3 0) (Ref rn4 2) - linkNodes (Ref rn4 0) (Ref rn5 1) - linkNodes (Ref rn4 1) (Ref rn6 1) - linkNodes (Ref rn5 0) (Ref rn7 1) - linkNodes (Ref rn6 0) (Ref rn8 1) - linkNodes r0 $ Ref rn3 1 - linkNodes r1 $ Ref rn7 0 - linkNodes r2 $ Ref rn8 0 -reduceNode n0@Branch1Node {} n1@AccumIONode {} = reduceNode n1 n0 reduceNode (AccumNBNode bs _ r0) (NamedBlockNode nbs _) = propagate1 r0 $ IONode $ B._namedBlocks %~ (<>) nbs $ bs reduceNode n0@NamedBlockNode {} n1@AccumNBNode {} = reduceNode n1 n0 @@ -561,25 +537,23 @@ reduceNode (Bind0BNode _ r0) (PArgumentNode _ r1 r2) = do linkNodes r2 $ Ref rn3 2 reassocCont r0 $ Ref rn3 0 reduceNode n0@PArgumentNode {} n1@Bind0BNode {} = reduceNode n1 n0 -reduceNode (Bind0CNode _ r0) (IOPureNode _ r1) = linkNodes r0 r1 -reduceNode n0@IOPureNode {} n1@Bind0CNode {} = reduceNode n1 n0 -reduceNode (Bind0FNode name _ r0) (IOContNode instr _) = do - let op = B.Reference (B.instrType instr) name - rn2 <- newNode $ LamNode () () () - rn3 <- newNode $ Bind1FNode (name B.:= instr) () () - rn4 <- newNode $ AppNode () () () - rn5 <- newNode $ OperandNode op () - linkNodes (Ref rn2 1) (Ref rn4 0) - linkNodes (Ref rn2 2) (Ref rn3 0) - linkNodes (Ref rn3 1) (Ref rn4 2) - linkNodes (Ref rn4 1) (Ref rn5 0) - linkNodes r0 $ Ref rn2 0 -reduceNode n0@IOContNode {} n1@Bind0FNode {} = reduceNode n1 n0 -reduceNode (Branch0FNode _ r0 r1 r2) (OperandNode op _) = do - rn3 <- newNode $ Branch1Node op () () () +reduceNode (Bind0CNode _ r0 r1) (IOPureNode _ r2) = do + rn3 <- newNode $ AppNode () () () linkNodes r0 $ Ref rn3 1 linkNodes r1 $ Ref rn3 2 linkNodes r2 $ Ref rn3 0 +reduceNode n0@IOPureNode {} n1@Bind0CNode {} = reduceNode n1 n0 +reduceNode (Bind0FNode name _ r0 r1) (IOContNode instr _) = do + let op = B.Reference (B.instrType instr) name + rn2 <- newNode $ Bind1FNode (name B.:= instr) () () + rn3 <- newNode $ AppNode () () () + rn4 <- newNode $ OperandNode op () + linkNodes (Ref rn2 1) (Ref rn3 2) + linkNodes (Ref rn3 1) (Ref rn4 0) + linkNodes r0 $ Ref rn3 0 + linkNodes r1 $ Ref rn2 0 +reduceNode n0@IOContNode {} n1@Bind0FNode {} = reduceNode n1 n0 +reduceNode (Branch0FNode _ r0 r1 r2) (OperandNode op _) = mkBranch1 op r0 r1 r2 reduceNode n0@OperandNode {} n1@Branch0FNode {} = reduceNode n1 n0 reduceNode (LabelNode lbl _ r0) (IONode bs _) = propagate1 r0 $ NamedBlockNode $ B.NamedBlockList $ IM.insert (B.unLabel lbl) (B.entryBlock bs) @@ -624,24 +598,22 @@ reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Bind1CNode _ r3 r4) = do name <- newName rn5 <- newNode $ TBuildNode lvl BuildOperand namep () () () () rn6 <- newNode $ TBuildNode lvl BuildIO namep () () () () - rn7 <- newNode $ Bind0FNode name () () - rn8 <- newNode $ AppNode () () () + rn7 <- newNode $ Bind0FNode name () () () + rn8 <- newNode $ TSplitNode () () () rn9 <- newNode $ TSplitNode () () () - rn10 <- newNode $ TSplitNode () () () - rn11 <- newNode $ PReduceNode () () - linkNodes (Ref rn5 1) (Ref rn9 1) - linkNodes (Ref rn5 2) (Ref rn10 1) - linkNodes (Ref rn5 3) (Ref rn11 0) - linkNodes (Ref rn6 1) (Ref rn9 2) - linkNodes (Ref rn6 2) (Ref rn10 2) - linkNodes (Ref rn6 0) (Ref rn8 2) - linkNodes (Ref rn7 0) (Ref rn11 1) - linkNodes (Ref rn7 1) (Ref rn8 0) - linkNodes r0 $ Ref rn9 0 - linkNodes r1 $ Ref rn10 0 + rn10 <- newNode $ PReduceNode () () + linkNodes (Ref rn5 1) (Ref rn8 1) + linkNodes (Ref rn5 2) (Ref rn9 1) + linkNodes (Ref rn5 3) (Ref rn10 0) + linkNodes (Ref rn6 1) (Ref rn8 2) + linkNodes (Ref rn6 2) (Ref rn9 2) + linkNodes (Ref rn6 0) (Ref rn7 2) + linkNodes (Ref rn7 0) (Ref rn10 1) + linkNodes r0 $ Ref rn8 0 + linkNodes r1 $ Ref rn9 0 linkNodes r2 $ Ref rn6 3 linkNodes r3 $ Ref rn5 0 - linkNodes r4 $ Ref rn8 1 + linkNodes r4 $ Ref rn7 1 reduceNode n0@Bind1CNode {} n1@TBuildNode {} = reduceNode n1 n0 reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Bind1FNode instr _ r3) = do rn4 <- newNode $ TBuildNode lvl BuildIO namep () () () () @@ -679,10 +651,6 @@ reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Branch0CNode _ r3 r4 r5) = do linkNodes r4 $ Ref rn7 0 linkNodes r5 $ Ref rn8 0 reduceNode n0@Branch0CNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl t namep _ r0 r1 r2) (Branch1Node opc _ r3 r4) - = commute2a' (TBuildNode lvl t namep) TSplitNode TSplitNode - (Branch1Node opc) r0 r1 r2 r3 r4 -reduceNode n0@Branch1Node {} n1@TBuildNode {} = reduceNode n1 n0 reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (PArgumentNode _ r3 r4) = do rn5 <- newNode $ TBuildNode lvl BuildOperand namep () () () () rn6 <- newNode $ TBuildNode lvl BuildOperand namep () () () () @@ -825,8 +793,8 @@ reduceNode n0@ReturnCNode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (Bind0BNode _ r2) = commute1 (DupNode lvl) Bind0BNode r0 r1 r2 reduceNode n0@Bind0BNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl _ r0 r1) (Bind0CNode _ r2) - = commute1 (DupNode lvl) Bind0CNode r0 r1 r2 +reduceNode (DupNode lvl _ r0 r1) (Bind0CNode _ r2 r3) + = commute2 (DupNode lvl) Bind0CNode r0 r1 r2 r3 reduceNode n0@Bind0CNode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (Bind1CNode _ r2 r3) = do rn4 <- newNode $ Bind1CNode () () () @@ -841,12 +809,6 @@ reduceNode (DupNode lvl _ r0 r1) (Branch0CNode _ r2 r3 r4) = do linkNodes r4 $ Ref rn5 3 dedupIO lvl r0 r1 $ Ref rn5 0 reduceNode n0@Branch0CNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl _ r0 r1) (Branch1Node opc _ r2 r3) = do - rn4 <- newNode $ Branch1Node opc () () () - linkNodes r2 $ Ref rn4 1 - linkNodes r3 $ Ref rn4 2 - dedupIO lvl r0 r1 $ Ref rn4 0 -reduceNode n0@Branch1Node {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl0 _ r0 r1) (TBuildNode lvl1 t namep _ r2 r3 r4) | lvl0 == lvl1 = do let opp = B.Reference (B.IntType 1) namep @@ -865,11 +827,7 @@ reduceNode (DupNode lvl0 _ r0 r1) (TBuildNode lvl1 t namep _ r2 r3 r4) linkNodes (Ref rn6 2) (Ref rn8 1) linkNodes (Ref rn7 1) (Ref rn8 0) linkNodes r4 $ Ref rn8 2 - BuildIO -> do - rn7 <- newNode $ Branch1Node opp () () () - linkNodes (Ref rn5 2) (Ref rn7 1) - linkNodes (Ref rn6 2) (Ref rn7 2) - linkNodes r4 $ Ref rn7 0 + BuildIO -> mkBranch1 opp (Ref rn5 2) (Ref rn6 2) r4 | otherwise = do let opp = B.Partial (SSucc $ SSucc SZero) $ mkSelect $ B.Reference (B.IntType 1) namep @@ -932,7 +890,7 @@ reduceNode (IOContNode _ _) (DeadNode _) = pure () reduceNode n0@DeadNode {} n1@IOContNode {} = reduceNode n1 n0 reduceNode (Bind0BNode _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@Bind0BNode {} = reduceNode n1 n0 -reduceNode (Bind0CNode _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode (Bind0CNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@Bind0CNode {} = reduceNode n1 n0 reduceNode (Bind1FNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@Bind1FNode {} = reduceNode n1 n0 @@ -983,11 +941,11 @@ reduceNode n0@BoxNode {} n1@ReturnFNode {} = reduceNode n1 n0 reduceNode (Bind0BNode _ r0) (BoxNode lvl _ r1) = commute0 Bind0BNode (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@Bind0BNode {} = reduceNode n1 n0 -reduceNode (Bind0CNode _ r0) (BoxNode lvl _ r1) - = commute0 Bind0CNode (BoxNode lvl) r0 r1 +reduceNode (Bind0CNode _ r0 r1) (BoxNode lvl _ r2) + = commute1 Bind0CNode (BoxNode lvl) r0 r1 r2 reduceNode n0@BoxNode {} n1@Bind0CNode {} = reduceNode n1 n0 -reduceNode (Bind0FNode name _ r0) (BoxNode lvl _ r1) - = commute0 (Bind0FNode name) (BoxNode lvl) r0 r1 +reduceNode (Bind0FNode name _ r0 r1) (BoxNode lvl _ r2) + = commute1 (Bind0FNode name) (BoxNode lvl) r0 r1 r2 reduceNode n0@BoxNode {} n1@Bind0FNode {} = reduceNode n1 n0 reduceNode (Bind1CNode _ r0 r1) (BoxNode lvl _ r2) = commute1 Bind1CNode (BoxNode lvl) r0 r1 r2 @@ -1001,20 +959,23 @@ reduceNode n0@BoxNode {} n1@Branch0CNode {} = reduceNode n1 n0 reduceNode (Branch0FNode _ r0 r1 r2) (BoxNode lvl _ r3) = commute2b Branch0FNode (BoxNode lvl) r0 r1 r2 r3 reduceNode n0@BoxNode {} n1@Branch0FNode {} = reduceNode n1 n0 -reduceNode (Branch1Node opp _ r0 r1) (BoxNode lvl _ r2) - = commute1 (Branch1Node opp) (BoxNode lvl) r0 r1 r2 -reduceNode n0@BoxNode {} n1@Branch1Node {} = reduceNode n1 n0 reduceNode (LabelNode lbl _ r0) (BoxNode _ _ r1) = do rn2 <- newNode $ LabelNode lbl () () linkNodes r0 $ Ref rn2 1 linkNodes r1 $ Ref rn2 0 reduceNode n0@BoxNode {} n1@LabelNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl0 t namep _ r0 r1 r2) (BoxNode lvl1 _ r3) - = commute2b - (TBuildNode (if lvl0 < lvl1 then lvl0 else succ lvl0) t namep) - (BoxNode lvl1) - r0 r1 r2 r3 +reduceNode (TBuildNode lvl0 t namep _ r0 r1 r2) (BoxNode lvl1 _ r3) = do + let lvl0' = if lvl0 < lvl1 then lvl0 else succ lvl0 + rn4 <- newNode $ TBuildNode lvl0' t namep () () () () + rn5 <- newNode $ BoxNode lvl1 () () + rn6 <- newNode $ BoxNode lvl1 () () + linkNodes (Ref rn4 1) (Ref rn5 1) + linkNodes (Ref rn4 2) (Ref rn6 1) + linkNodes r0 $ Ref rn5 0 + linkNodes r1 $ Ref rn6 0 + linkNodes r2 $ Ref rn4 3 + linkNodes r3 $ Ref rn4 0 reduceNode n0@BoxNode {} n1@TBuildNode {} = reduceNode n1 n0 reduceNode (TEntryNode name opp _ r0) (BoxNode lvl _ r1) = commute0 (TEntryNode name opp) (BoxNode lvl) r0 r1 @@ -1024,8 +985,13 @@ reduceNode (TSplitNode _ r0 r1) (BoxNode lvl _ r2) reduceNode n0@BoxNode {} n1@TSplitNode {} = reduceNode n1 n0 reduceNode (TCloseNode _) (BoxNode _ _ r0) = propagate1 r0 TCloseNode reduceNode n0@BoxNode {} n1@TCloseNode {} = reduceNode n1 n0 -reduceNode (TLeaveNode t _ r0 r1) (BoxNode lvl _ r2) - = commute1 (TLeaveNode t) (BoxNode lvl) r0 r1 r2 +reduceNode (TLeaveNode t _ r0 r1) (BoxNode lvl _ r2) = do + rn3 <- newNode $ TLeaveNode t () () () + rn4 <- newNode $ BoxNode lvl () () + linkNodes (Ref rn3 1) (Ref rn4 1) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn3 2 + linkNodes r2 $ Ref rn3 0 reduceNode n0@BoxNode {} n1@TLeaveNode {} = reduceNode n1 n0 reduceNode (TMatchNode lvl0 _ r0 r1 r2) (BoxNode lvl1 _ r3) = commute2b (TMatchNode $ if lvl0 < lvl1 then lvl0 else succ lvl0) @@ -1035,8 +1001,10 @@ reduceNode n0@BoxNode {} n1@TMatchNode {} = reduceNode n1 n0 reduceNode (PArgumentNode _ r0 r1) (BoxNode lvl _ r2) = commute1 PArgumentNode (BoxNode lvl) r0 r1 r2 reduceNode n0@BoxNode {} n1@PArgumentNode {} = reduceNode n1 n0 -reduceNode (PReduceNode _ r0) (BoxNode lvl _ r1) - = commute0 PReduceNode (BoxNode lvl) r0 r1 +reduceNode (PReduceNode _ r0) (BoxNode _ _ r1) = do + rn2 <- newNode $ PReduceNode () () + linkNodes r0 $ Ref rn2 1 + linkNodes r1 $ Ref rn2 0 reduceNode n0@BoxNode {} n1@PReduceNode {} = reduceNode n1 n0 reduceNode n0 n1 = error . show $ "unexpected node pairing" <> line <> pretty n0 <> line <> pretty n1 @@ -1198,31 +1166,29 @@ reassocPure r0 r1 = do rn4 <- newNode $ LamNode () () () rn5 <- newNode $ AppNode () () () rn6 <- newNode $ LamNode () () () - rn7 <- newNode $ Bind0CNode () () + rn7 <- newNode $ Bind0CNode () () () rn8 <- newNode $ AppNode () () () - rn9 <- newNode $ AppNode () () () + rn9 <- newNode $ BoxNode 0 () () rn10 <- newNode $ BoxNode 0 () () rn11 <- newNode $ BoxNode 0 () () rn12 <- newNode $ BoxNode 0 () () rn13 <- newNode $ BoxNode 0 () () - rn14 <- newNode $ BoxNode 0 () () - linkNodes (Ref rn2 1) (Ref rn13 0) + linkNodes (Ref rn2 1) (Ref rn12 0) linkNodes (Ref rn2 2) (Ref rn3 0) linkNodes (Ref rn3 1) (Ref rn4 0) - linkNodes (Ref rn4 1) (Ref rn10 0) + linkNodes (Ref rn4 1) (Ref rn9 0) linkNodes (Ref rn4 2) (Ref rn5 2) - linkNodes (Ref rn5 0) (Ref rn12 1) + linkNodes (Ref rn5 0) (Ref rn11 1) linkNodes (Ref rn5 1) (Ref rn6 0) - linkNodes (Ref rn6 1) (Ref rn9 1) - linkNodes (Ref rn6 2) (Ref rn8 2) - linkNodes (Ref rn7 0) (Ref rn9 2) - linkNodes (Ref rn7 1) (Ref rn8 0) - linkNodes (Ref rn8 1) (Ref rn10 1) - linkNodes (Ref rn9 0) (Ref rn14 1) - linkNodes (Ref rn11 1) (Ref rn12 0) - linkNodes (Ref rn13 1) (Ref rn14 0) + linkNodes (Ref rn6 1) (Ref rn8 1) + linkNodes (Ref rn6 2) (Ref rn7 2) + linkNodes (Ref rn7 0) (Ref rn8 2) + linkNodes (Ref rn7 1) (Ref rn9 1) + linkNodes (Ref rn8 0) (Ref rn13 1) + linkNodes (Ref rn10 1) (Ref rn11 0) + linkNodes (Ref rn12 1) (Ref rn13 0) linkNodes r0 $ Ref rn2 0 - linkNodes r1 $ Ref rn11 0 + linkNodes r1 $ Ref rn10 0 {-# INLINABLE reassocPure #-} -- | @r0 = \a -> IOPure (\b -> Bind1C r1 (\c -> Bind0C (a c) b))@ @@ -1235,12 +1201,11 @@ reassocCont r0 r1 = do rn6 <- newNode $ BoxNode 0 () () rn7 <- newNode $ BoxNode 0 () () rn8 <- newNode $ LamNode () () () - rn9 <- newNode $ Bind0CNode () () + rn9 <- newNode $ Bind0CNode () () () rn10 <- newNode $ AppNode () () () rn11 <- newNode $ BoxNode 0 () () rn12 <- newNode $ BoxNode 0 () () rn13 <- newNode $ BoxNode 0 () () - rn14 <- newNode $ AppNode () () () linkNodes (Ref rn2 1) (Ref rn11 0) linkNodes (Ref rn2 2) (Ref rn3 0) linkNodes (Ref rn3 1) (Ref rn4 0) @@ -1250,16 +1215,36 @@ reassocCont r0 r1 = do linkNodes (Ref rn5 2) (Ref rn8 0) linkNodes (Ref rn6 1) (Ref rn7 0) linkNodes (Ref rn8 1) (Ref rn10 1) - linkNodes (Ref rn8 2) (Ref rn14 2) + linkNodes (Ref rn8 2) (Ref rn9 2) linkNodes (Ref rn9 0) (Ref rn10 2) - linkNodes (Ref rn9 1) (Ref rn14 0) + linkNodes (Ref rn9 1) (Ref rn13 1) linkNodes (Ref rn10 0) (Ref rn12 1) linkNodes (Ref rn11 1) (Ref rn12 0) - linkNodes (Ref rn13 1) (Ref rn14 1) linkNodes r0 $ Ref rn2 0 linkNodes r1 $ Ref rn6 0 {-# INLINABLE reassocCont #-} +mkBranch1 :: HasRewriter sig m => B.Operand -> Ref -> Ref -> Ref -> m () +mkBranch1 opc r0 r1 r2 = do + lblt <- newLabel + lblf <- newLabel + let b = B.Block mempty $ B.Branch opc lblt lblf + rn3 <- newNode $ AccumNBNode (B.BlockList b mempty) () () + rn4 <- newNode $ Merge0Node () () () + rn5 <- newNode $ LabelNode lblt () () + rn6 <- newNode $ LabelNode lblf () () + rn7 <- newNode $ AccumIONode mempty () () + rn8 <- newNode $ AccumIONode mempty () () + linkNodes (Ref rn3 0) (Ref rn4 2) + linkNodes (Ref rn4 0) (Ref rn5 1) + linkNodes (Ref rn4 1) (Ref rn6 1) + linkNodes (Ref rn5 0) (Ref rn7 1) + linkNodes (Ref rn6 0) (Ref rn8 1) + linkNodes r0 $ Ref rn7 0 + linkNodes r1 $ Ref rn8 0 + linkNodes r2 $ Ref rn3 1 +{-# INLINABLE mkBranch1 #-} + mkLambda :: HasRewriter sig m => Ref -> (() -> () -> INetF ()) -> m () mkLambda r0 mk1 = do rn1 <- newNode $ mk1 () () diff --git a/test/Golden.hs b/test/Golden.hs index acbdf18..d314d03 100644 --- a/test/Golden.hs +++ b/test/Golden.hs @@ -269,7 +269,7 @@ data NodeHead | IOHead | IOAHead | IOPHead | IOPureHead | IOContHead | ReturnCHead | ReturnFHead | Bind0BHead | Bind0CHead | Bind0FHead | Bind1CHead | Bind1FHead - | Branch0CHead | Branch0FHead | Branch1Head + | Branch0CHead | Branch0FHead | LabelHead | NamedBlockHead | Merge0Head | Merge1Head | TBuildHead | TEntryHead | TSplitHead | TCloseHead | TLeaveHead | TMatchHead @@ -303,7 +303,6 @@ instance Pretty NodeHead where pretty Bind1FHead = "Bind1F" pretty Branch0CHead = "Branch0C" pretty Branch0FHead = "Branch0F" - pretty Branch1Head = "Branch1" pretty LabelHead = "Label" pretty NamedBlockHead = "NamedBlock" pretty Merge0Head = "Merge0" @@ -345,7 +344,6 @@ nodeHead x = case x of Bind1FNode {} -> Bind1FHead Branch0CNode {} -> Branch0CHead Branch0FNode {} -> Branch0FHead - Branch1Node {} -> Branch1Head LabelNode {} -> LabelHead NamedBlockNode {} -> NamedBlockHead Merge0Node {} -> Merge0Head diff --git a/test/Golden/CataStaticAccum.opt.ll b/test/Golden/CataStaticAccum.opt.ll index 1598216..fa6d66c 100644 --- a/test/Golden/CataStaticAccum.opt.ll +++ b/test/Golden/CataStaticAccum.opt.ll @@ -4,11 +4,17 @@ source_filename = "test/Golden/CataStaticAccum.elem" declare i1 @dothing() local_unnamed_addr define i1 @main() local_unnamed_addr { -__elem_2.exit: - %0 = tail call i1 @dothing() %1 = tail call i1 @dothing() %2 = tail call i1 @dothing() - %spec.select = xor i1 %0, %1 - %3 = xor i1 %2, %spec.select - ret i1 %3 + %3 = tail call i1 @dothing() + %not.1 = xor i1 %3, true + br i1 %1, label %4, label %__elem_2.exit + +4: ; preds = %0 + %spec.select = select i1 %2, i1 %3, i1 %not.1 + ret i1 %spec.select + +__elem_2.exit: ; preds = %0 + %spec.select2 = select i1 %2, i1 %not.1, i1 %3 + ret i1 %spec.select2 } From a4881f1c4a2bdcf20e7f25a4dc66548bf44f35d8 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Sat, 25 Jun 2022 11:10:00 +0100 Subject: [PATCH 13/17] Add missing reduction rules --- src/Language/Elemental/InteractionNet.hs | 32 ++++++++++++++++++++++++ 1 file changed, 32 insertions(+) diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 3df6336..835de04 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -744,6 +744,30 @@ reduceNode (PArgumentNode _ r0 r1) (AppNode _ r2 r3) = do linkNodes r2 $ Ref rn5 2 linkNodes r3 $ Ref rn5 0 reduceNode n0@AppNode {} n1@PArgumentNode {} = reduceNode n1 n0 +reduceNode (PArgumentNode _ r0 r1) (OperandPNode opp _ r2) = do + rn3 <- newNode $ AppNode () () () + rn4 <- newNode $ PReduceNode () () + rn5 <- newNode $ PReduceNode () () + rn6 <- newNode $ OperandPNode opp () () + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes (Ref rn3 1) (Ref rn5 1) + linkNodes (Ref rn3 2) (Ref rn6 0) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn5 0 + linkNodes r2 $ Ref rn6 1 +reduceNode n0@OperandPNode {} n1@PArgumentNode {} = reduceNode n1 n0 +reduceNode (PArgumentNode _ r0 r1) (IOPNode iop _ r2) = do + rn3 <- newNode $ AppNode () () () + rn4 <- newNode $ PReduceNode () () + rn5 <- newNode $ PReduceNode () () + rn6 <- newNode $ IOPNode iop () () + linkNodes (Ref rn3 0) (Ref rn4 1) + linkNodes (Ref rn3 1) (Ref rn5 1) + linkNodes (Ref rn3 2) (Ref rn6 0) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn5 0 + linkNodes r2 $ Ref rn6 1 +reduceNode n0@IOPNode {} n1@PArgumentNode {} = reduceNode n1 n0 reduceNode (PArgumentNode _ r0 r1) (PReduceNode _ r2) = do rn3 <- newNode $ AppNode () () () rn4 <- newNode $ PReduceNode () () @@ -769,6 +793,9 @@ reduceNode n0@IOContNode {} n1@PReduceNode {} = reduceNode n1 n0 reduceNode (DupNode _ _ r0 r1) (OperandNode op _) = propagate2 r0 r1 $ OperandNode op reduceNode n0@OperandNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode _ _ r0 r1) (OperandANode opp _) + = propagate2 r0 r1 $ OperandANode opp +reduceNode n0@OperandANode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (OperandPNode opp _ r2) = commute1 (DupNode lvl) (OperandPNode opp) r0 r1 r2 reduceNode n0@OperandPNode {} n1@DupNode {} = reduceNode n1 n0 @@ -776,6 +803,8 @@ reduceNode (DupNode lvl _ r0 r1) (IONode bs _) = do rn2 <- newNode $ IONode bs () dedupIO lvl r0 r1 $ Ref rn2 0 reduceNode n0@IONode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode _ _ r0 r1) (IOANode iop _) = propagate2 r0 r1 $ IOANode iop +reduceNode n0@IOANode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (IOPNode iop _ r2) = commute1 (DupNode lvl) (IOPNode iop) r0 r1 r2 reduceNode n0@IOPNode {} n1@DupNode {} = reduceNode n1 n0 @@ -872,6 +901,9 @@ reduceNode (DupNode lvl _ r0 r1) (TEntryNode name opp _ r2) = do linkNodes r2 $ Ref rn3 1 dedupIO lvl r0 r1 $ Ref rn3 0 reduceNode n0@TEntryNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (PArgumentNode _ r2 r3) + = commute2 (DupNode lvl) PArgumentNode r0 r1 r2 r3 +reduceNode n0@PArgumentNode {} n1@DupNode {} = reduceNode n1 n0 -- FFI Dead reduceNode (AccumIONode ib _ r0) (DeadNode _) = propagate1 r0 $ IONode $ B.BlockList (B.Block (B.unIBlock ib) B.Unreachable) mempty From 7dcbe0969c5d61a139471018bf36a62b41da6c25 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Sat, 25 Jun 2022 11:11:42 +0100 Subject: [PATCH 14/17] Fix Level and Int thunk buildup in nets --- src/Language/Elemental/InteractionNet.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 835de04..c693cf8 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -120,9 +120,9 @@ _INetPairs = iso unINetPairs INetPairs -- | A reference to a port in an interaction net. data Ref = Ref - { refNode :: Int + { refNode :: {-# UNPACK #-} !Int -- ^ The index of the port's node. - , refPort :: Int + , refPort :: {-# UNPACK #-} !Int -- ^ The index of the port within the node's port list. } deriving stock (Eq, Ord, Show) @@ -168,11 +168,11 @@ data INetF a -- | (a -> b, a, b) | LamNode a a a -- | (a, a, a) - | DupNode Level a a a + | DupNode !Level a a a -- | a | DeadNode a -- | (a, a) and the non-principal node is in a new box. - | BoxNode Level a a + | BoxNode !Level a a -- FFI -- | CB | ExternalRootNode B.ForeignName [B.Named B.Type] B.Type a @@ -225,7 +225,7 @@ data INetF a -- | (NB, NB) | Merge1Node B.NamedBlockList a a -- | (a, T, T, a) - | TBuildNode Level BuildType B.Name a a a a + | TBuildNode !Level BuildType B.Name a a a a -- | (B, T) | TEntryNode B.Name B.Operand a a -- | (T, T, T) @@ -235,7 +235,7 @@ data INetF a -- | (T, a, a) | TLeaveNode BuildType a a a -- | (T, T, T, i1) - | TMatchNode Level a a a a + | TMatchNode !Level a a a a -- | (a, i{n} -> a, i{n}) | PArgumentNode a a a -- | (a, a) From b65f557f20366269223c43d9e12950853a139421 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Sat, 25 Jun 2022 13:14:33 +0100 Subject: [PATCH 15/17] Avoid redundant reductions in tunnels Replace TBuild with TCross when in a tunnel. --- src/Language/Elemental/InteractionNet.hs | 93 ++++++++++++------------ test/Golden.hs | 8 +- 2 files changed, 52 insertions(+), 49 deletions(-) diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index c693cf8..3c4e8f9 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -226,6 +226,8 @@ data INetF a | Merge1Node B.NamedBlockList a a -- | (a, T, T, a) | TBuildNode !Level BuildType B.Name a a a a + -- | (T, T, T) + | TCrossNode !Level B.Name a a a -- | (B, T) | TEntryNode B.Name B.Operand a a -- | (T, T, T) @@ -297,6 +299,9 @@ instance Pretty a => Pretty (INetF a) where pretty (TBuildNode lvl t namep r0 r1 r2 r3) = "TBuild" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 <+> pretty t <+> pretty namep + pretty (TCrossNode lvl namep r0 r1 r2) + = "TCross" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 + <+> pretty namep pretty (TEntryNode name opp r0 r1) = "TEntry" <+> pretty r0 <+> pretty r1 <+> pretty name <+> pretty opp pretty (TSplitNode r0 r1 r2) @@ -674,67 +679,58 @@ reduceNode (AccumIONode ib _ r0) (TEntryNode name opp _ r1) = do propagate1 r0 $ IONode $ B.BlockList (B.Block (B.unIBlock ib) term) mempty propagate1 r1 TCloseNode reduceNode n0@TEntryNode {} n1@AccumIONode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl t namep _ r0 r1 r2) (TEntryNode name opp _ r3) = do - rn4 <- newNode $ TBuildNode lvl t namep () () () () - rn5 <- newNode $ TEntryNode name opp () () - linkNodes (Ref rn4 3) (Ref rn5 1) +reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (TEntryNode name opp _ r3) = do + let term = B.TailCall name opp + rn4 <- newNode $ TCrossNode lvl namep () () () + propagate1 r2 $ IONode $ B.BlockList (B.Block mempty term) mempty linkNodes r0 $ Ref rn4 1 linkNodes r1 $ Ref rn4 2 - linkNodes r2 $ Ref rn5 0 linkNodes r3 $ Ref rn4 0 reduceNode n0@TEntryNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl t namep _ r0 r1 r2) (TSplitNode _ r3 r4) - = commute2a (TBuildNode lvl t namep) TSplitNode r0 r1 r2 r3 r4 -reduceNode n0@TSplitNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (TCloseNode _) - = propagate3 r0 r1 r2 TCloseNode -reduceNode n0@TCloseNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TCrossNode lvl namep _ r0 r1) (TSplitNode _ r2 r3) + = commute2 (TCrossNode lvl namep) TSplitNode r0 r1 r2 r3 +reduceNode n0@TSplitNode {} n1@TCrossNode {} = reduceNode n1 n0 +reduceNode (TCrossNode _ _ _ r0 r1) (TCloseNode _) = propagate2 r0 r1 TCloseNode +reduceNode n0@TCloseNode {} n1@TCrossNode {} = reduceNode n1 n0 reduceNode (TSplitNode _ r0 r1) (TCloseNode _) = propagate2 r0 r1 TCloseNode reduceNode n0@TCloseNode {} n1@TSplitNode {} = reduceNode n1 n0 reduceNode (TCloseNode _) (TCloseNode _) = pure () -reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (TLeaveNode t _ r3 r4) = do - rn5 <- newNode $ TBuildNode lvl t namep () () () () - rn6 <- newNode $ TLeaveNode t () () () - linkNodes (Ref rn5 3) (Ref rn6 1) - linkNodes r0 $ Ref rn5 1 - linkNodes r1 $ Ref rn5 2 - linkNodes r2 $ Ref rn6 0 - linkNodes r3 $ Ref rn5 0 - linkNodes r4 $ Ref rn6 2 -reduceNode n0@TLeaveNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TCrossNode lvl namep _ r0 r1) (TLeaveNode t _ r2 r3) = do + rn4 <- newNode $ TBuildNode lvl t namep () () () () + linkNodes r0 $ Ref rn4 1 + linkNodes r1 $ Ref rn4 2 + linkNodes r2 $ Ref rn4 0 + linkNodes r3 $ Ref rn4 3 +reduceNode n0@TLeaveNode {} n1@TCrossNode {} = reduceNode n1 n0 reduceNode (TLeaveNode _ _ r0 r1) (TCloseNode _) = linkNodes r0 r1 reduceNode n0@TCloseNode {} n1@TLeaveNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl0 t namep _ r0 r1 r2) (TMatchNode lvl1 _ r3 r4 r5) +reduceNode (TCrossNode lvl0 namep _ r0 r1) (TMatchNode lvl1 _ r2 r3 r4) | lvl0 == lvl1 = do - linkNodes r0 r3 - linkNodes r1 r4 - propagate1 r2 TCloseNode - propagate1 r5 $ OperandNode $ B.Reference (B.IntType 1) namep + linkNodes r0 r2 + linkNodes r1 r3 + propagate1 r4 $ OperandNode $ B.Reference (B.IntType 1) namep | otherwise = do let opp = B.Partial (SSucc $ SSucc SZero) $ mkSelect $ B.Reference (B.IntType 1) namep - rn6 <- newNode $ TBuildNode lvl0 t namep () () () () - rn7 <- newNode $ TBuildNode lvl0 t namep () () () () + rn5 <- newNode $ TCrossNode lvl0 namep () () () + rn6 <- newNode $ TCrossNode lvl0 namep () () () + rn7 <- newNode $ TMatchNode lvl1 () () () () rn8 <- newNode $ TMatchNode lvl1 () () () () - rn9 <- newNode $ TMatchNode lvl1 () () () () - rn10 <- newNode $ OperandPNode opp () () - rn11 <- newNode $ AppNode () () () - linkNodes (Ref rn6 1) (Ref rn8 1) - linkNodes (Ref rn6 2) (Ref rn9 1) - propagate1 (Ref rn6 3) TCloseNode - linkNodes (Ref rn7 1) (Ref rn8 2) - linkNodes (Ref rn7 2) (Ref rn9 2) - propagate1 (Ref rn7 3) TCloseNode - linkNodes (Ref rn8 3) (Ref rn10 0) - linkNodes (Ref rn9 3) (Ref rn11 1) - linkNodes (Ref rn10 1) (Ref rn11 0) - linkNodes r0 $ Ref rn8 0 - linkNodes r1 $ Ref rn9 0 - propagate1 r2 TCloseNode + rn9 <- newNode $ OperandPNode opp () () + rn10 <- newNode $ AppNode () () () + linkNodes (Ref rn5 1) (Ref rn7 1) + linkNodes (Ref rn5 2) (Ref rn8 1) + linkNodes (Ref rn6 1) (Ref rn7 2) + linkNodes (Ref rn6 2) (Ref rn8 2) + linkNodes (Ref rn7 3) (Ref rn9 0) + linkNodes (Ref rn8 3) (Ref rn10 1) + linkNodes (Ref rn9 1) (Ref rn10 0) + linkNodes r0 $ Ref rn7 0 + linkNodes r1 $ Ref rn8 0 + linkNodes r2 $ Ref rn5 0 linkNodes r3 $ Ref rn6 0 - linkNodes r4 $ Ref rn7 0 - linkNodes r5 $ Ref rn11 2 -reduceNode n0@TMatchNode {} n1@TBuildNode {} = reduceNode n1 n0 + linkNodes r4 $ Ref rn10 2 +reduceNode n0@TMatchNode {} n1@TCrossNode {} = reduceNode n1 n0 reduceNode (PArgumentNode _ r0 r1) (AppNode _ r2 r3) = do rn4 <- newNode $ PArgumentNode () () () rn5 <- newNode $ PArgumentNode () () () @@ -1009,6 +1005,11 @@ reduceNode (TBuildNode lvl0 t namep _ r0 r1 r2) (BoxNode lvl1 _ r3) = do linkNodes r2 $ Ref rn4 3 linkNodes r3 $ Ref rn4 0 reduceNode n0@BoxNode {} n1@TBuildNode {} = reduceNode n1 n0 +reduceNode (TCrossNode lvl0 namep _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (TCrossNode (if lvl0 < lvl1 then lvl0 else succ lvl0) namep) + (BoxNode lvl1) + r0 r1 r2 +reduceNode n0@BoxNode {} n1@TCrossNode {} = reduceNode n1 n0 reduceNode (TEntryNode name opp _ r0) (BoxNode lvl _ r1) = commute0 (TEntryNode name opp) (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@TEntryNode {} = reduceNode n1 n0 diff --git a/test/Golden.hs b/test/Golden.hs index d314d03..acd3133 100644 --- a/test/Golden.hs +++ b/test/Golden.hs @@ -195,8 +195,8 @@ instance (MonadIO m, Has (State Count) sig m, Has (State INet) sig m (_, DeadNode {}) -> pure () (BoxNode {}, _) -> pure () (_, BoxNode {}) -> pure () - (TBuildNode {}, TSplitNode {}) -> pure () - (TSplitNode {}, TBuildNode {}) -> pure () + (TCrossNode {}, TSplitNode {}) -> pure () + (TSplitNode {}, TCrossNode {}) -> pure () (TCloseNode {}, _) -> pure () (_, TCloseNode {}) -> pure () _ -> liftIO $ hPrint h @@ -271,7 +271,7 @@ data NodeHead | Bind0BHead | Bind0CHead | Bind0FHead | Bind1CHead | Bind1FHead | Branch0CHead | Branch0FHead | LabelHead | NamedBlockHead | Merge0Head | Merge1Head - | TBuildHead | TEntryHead | TSplitHead + | TBuildHead | TCrossHead | TEntryHead | TSplitHead | TCloseHead | TLeaveHead | TMatchHead | PArgumentHead | PReduceHead deriving stock (Eq, Ord) @@ -308,6 +308,7 @@ instance Pretty NodeHead where pretty Merge0Head = "Merge0" pretty Merge1Head = "Merge1" pretty TBuildHead = "TBuild" + pretty TCrossHead = "TCross" pretty TEntryHead = "TEntry" pretty TSplitHead = "TSplit" pretty TCloseHead = "TClose" @@ -349,6 +350,7 @@ nodeHead x = case x of Merge0Node {} -> Merge0Head Merge1Node {} -> Merge1Head TBuildNode {} -> TBuildHead + TCrossNode {} -> TCrossHead TEntryNode {} -> TEntryHead TSplitNode {} -> TSplitHead TCloseNode {} -> TCloseHead From 706c5c3a092b29e0f07f8391f45f4628e50ed331 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Mon, 27 Jun 2022 16:20:14 +0100 Subject: [PATCH 16/17] Fix vicious cycles when a bind depends on itself Decide the name and pass the operand to the continuation before reducing the instruction. --- src/Language/Elemental/Emit.hs | 43 +- src/Language/Elemental/InteractionNet.hs | 591 ++++++++++++---- test/Golden.hs | 29 +- test/Golden/Arithmetic.opt.ll | 11 +- test/Golden/BitOrder.opt.ll | 5 +- test/Golden/BranchIO.opt.ll | 5 +- test/Golden/CallOrder.opt.ll | 57 +- test/Golden/CataDynamic.opt.ll | 8 +- test/Golden/CataStaticAccum.opt.ll | 13 +- test/Golden/EchoChar.opt.ll | 853 +---------------------- test/Golden/FunctionInIO.opt.ll | 11 +- test/Golden/MemoryBit.opt.ll | 10 +- test/Golden/NestedBranch.opt.ll | 12 +- test/Golden/NestedBranch2.opt.ll | 6 +- test/Golden/NestedBranch3.opt.ll | 10 +- test/Golden/ShareBindCont.opt.ll | 12 +- test/Golden/ShareIO.opt.ll | 14 +- test/Golden/ShareIOPoly.opt.ll | 9 +- 18 files changed, 538 insertions(+), 1161 deletions(-) diff --git a/src/Language/Elemental/Emit.hs b/src/Language/Elemental/Emit.hs index 4b8d0bb..590269a 100644 --- a/src/Language/Elemental/Emit.hs +++ b/src/Language/Elemental/Emit.hs @@ -174,8 +174,8 @@ emitExpr scope rr = \case rn1 <- newNode $ OperandNode op () linkNodes rr $ Ref rn1 0 BackendIO _ instr -> propagate1 rr $ IOContNode instr - BackendPIO _ _ pio - -> propagate1 rr $ IOANode (Backend.Partial (SSucc SZero) pio) + BackendPIO _ tret pio -> propagate1 rr + $ IOANode (backendType tret) (Backend.Partial (SSucc SZero) pio) PureIO -> do rn1 <- newNode $ LamNode () () () rn2 <- newNode $ IOPureNode () () @@ -204,7 +204,7 @@ emitExpr scope rr = \case let callp = Backend.Partial len $ withVarargs len $ Backend.Call (backendType tret) (Backend.ExternalName fname) len = sLength ltargs - propagate1 rr $ IOANode callp + propagate1 rr $ IOANode (backendType tret) callp IsolateBit bidx ssize -> do let opp = Backend.Partial (SSucc SZero) $ mkIsolateBit size bidx' size = fromIntegral $ toNatural ssize @@ -216,26 +216,25 @@ emitExpr scope rr = \case propagate1 rr $ OperandANode opp TestBit -> do rn1 <- newNode $ LamNode () () () - rn2 <- newNode $ DupNode 0 () () () - rn3 <- newNode $ AppNode () () () - rn4 <- newNode $ AppNode () () () - r5 <- mkChurchBool const - r6 <- mkChurchBool $ const id - rn7 <- newNode $ Branch0CNode () () () () - rn8 <- newNode $ LamNode () () () - rn9 <- newNode $ IOPureNode () () - linkNodes (Ref rn1 0) (Ref rn9 1) - linkNodes (Ref rn1 1) (Ref rn2 0) - linkNodes (Ref rn1 2) (Ref rn7 0) + rn2 <- newNode $ IOPureNode () () + rn3 <- newNode $ LamNode () () () + rn4 <- newNode $ DupIONode 0 () () () + rn5 <- newNode $ AppNode () () () + rn6 <- newNode $ DupNode 0 () () () + r7 <- mkChurchBool const + r8 <- mkChurchBool $ const id + rn9 <- newNode $ BoxNode 0 () () + linkNodes (Ref rn1 1) (Ref rn9 0) + linkNodes (Ref rn1 2) (Ref rn2 0) linkNodes (Ref rn2 1) (Ref rn3 0) - linkNodes (Ref rn2 2) (Ref rn4 0) - linkNodes (Ref rn3 2) (Ref rn7 2) - linkNodes (Ref rn4 2) (Ref rn7 3) - linkNodes (Ref rn8 1) (Ref rn7 1) - linkNodes (Ref rn8 2) (Ref rn9 0) - linkNodes r5 $ Ref rn3 1 - linkNodes r6 $ Ref rn4 1 - linkNodes rr $ Ref rn8 0 + linkNodes (Ref rn3 1) (Ref rn5 0) + linkNodes (Ref rn3 2) (Ref rn4 2) + linkNodes (Ref rn4 0) (Ref rn5 2) + linkNodes (Ref rn4 1) (Ref rn9 1) + linkNodes (Ref rn5 1) (Ref rn6 0) + linkNodes r7 $ Ref rn6 1 + linkNodes r8 $ Ref rn6 2 + linkNodes rr $ Ref rn1 0 where coerceScope :: SList (Const a) as -> SList (Const a) (IncrementAll 'Zero as) coerceScope SNil = SNil diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 3c4e8f9..27ebe3a 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -42,6 +42,7 @@ module Language.Elemental.InteractionNet , INetF(..) , Ref(..) , Level(..) + , BuildType(..) , HasRewriter , compileINet , reduce @@ -191,7 +192,7 @@ data INetF a -- | B | IONode B.BlockList a -- | {... ->} IO i{n} - | IOANode (B.Partial B.Instruction) a + | IOANode B.Type (B.Partial B.Instruction) a -- | (i{m}, {... ->} IO i{n}) | IOPNode (B.Partial B.Instruction) a a -- | (IO a, (a -> B) -> B) @@ -202,14 +203,16 @@ data INetF a | ReturnCNode a a -- | (i{n}, B) | ReturnFNode a a + -- | (i{n}, B) + | TailCallNode B.Name a a -- | (IO a, (a -> IO b) -> IO b) | Bind0BNode a a -- | (IO a, a -> B, B) | Bind0CNode a a a - -- | (IO a, a -> B, B) + -- | (IO a, B, B) | Bind0FNode B.Name a a a -- | (B, IO a, (a -> B) -> B) - | Bind1CNode a a a + | Bind1CNode B.Name a a a -- | (B, B) | Bind1FNode (B.Named B.Instruction) a a -- | (B, i{n}, B, B) @@ -224,12 +227,16 @@ data INetF a | Merge0Node a a a -- | (NB, NB) | Merge1Node B.NamedBlockList a a + -- | (a, T, a) + | TBuild1Node !Level BuildType B.Operand a a a -- | (a, T, T, a) - | TBuildNode !Level BuildType B.Name a a a a + | TBuild2Node !Level BuildType B.Operand a a a a + -- | (T, T) + | TCross1Node !Level B.Operand a a -- | (T, T, T) - | TCrossNode !Level B.Name a a a - -- | (B, T) - | TEntryNode B.Name B.Operand a a + | TCross2Node !Level B.Operand a a a + -- | (B, T, B) + | TEntryNode a a a -- | (T, T, T) | TSplitNode a a a -- | T @@ -239,9 +246,11 @@ data INetF a -- | (T, T, T, i1) | TMatchNode !Level a a a a -- | (a, i{n} -> a, i{n}) - | PArgumentNode a a a + | PArgumentNode (Maybe B.Type) a a a -- | (a, a) | PReduceNode a a + -- | (B, i{n}, B) + | DupIONode !Level a a a deriving stock (Foldable, Functor, Traversable) instance Pretty a => Pretty (INetF a) where @@ -267,7 +276,7 @@ instance Pretty a => Pretty (INetF a) where pretty (OperandPNode opp r0 r1) = "OperandP" <+> pretty r0 <+> pretty r1 <+> pretty opp pretty (IONode bs r0) = "IO" <+> pretty r0 <> nest 4 (line <> pretty bs) - pretty (IOANode iop r0) = "IOA" <+> pretty r0 <+> pretty iop + pretty (IOANode t iop r0) = "IOA" <+> pretty r0 <+> pretty t <+> pretty iop pretty (IOPNode iop r0 r1) = "IOP" <+> pretty r0 <+> pretty r1 <+> pretty iop pretty (IOPureNode r0 r1) = "IOPure" <+> pretty r0 <+> pretty r1 @@ -275,13 +284,15 @@ instance Pretty a => Pretty (INetF a) where = "IOCont" <+> pretty r0 <> nest 4 (line <> pretty instr) pretty (ReturnCNode r0 r1) = "ReturnC" <+> pretty r0 <+> pretty r1 pretty (ReturnFNode r0 r1) = "ReturnF" <+> pretty r0 <+> pretty r1 + pretty (TailCallNode name r0 r1) + = "TailCall" <+> pretty r0 <+> pretty r1 <+> pretty name pretty (Bind0BNode r0 r1) = "Bind0B" <+> pretty r0 <+> pretty r1 pretty (Bind0CNode r0 r1 r2) = "Bind0C" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (Bind0FNode name r0 r1 r2) = "Bind0F" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty name - pretty (Bind1CNode r0 r1 r2) - = "Bind1C" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (Bind1CNode name r0 r1 r2) + = "Bind1C" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty name pretty (Bind1FNode instr r0 r1) = "Bind1F" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty instr) pretty (Branch0CNode r0 r1 r2 r3) @@ -296,14 +307,19 @@ instance Pretty a => Pretty (INetF a) where = "Merge0" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (Merge1Node nbs r0 r1) = "Merge1" <+> pretty r0 <+> pretty r1 <> nest 4 (line <> pretty nbs) - pretty (TBuildNode lvl t namep r0 r1 r2 r3) = "TBuild" + pretty (TBuild1Node lvl t namep r0 r1 r2) = "TBuild1" + <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 + <+> pretty t <+> pretty namep + pretty (TBuild2Node lvl t namep r0 r1 r2 r3) = "TBuild2" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 <+> pretty t <+> pretty namep - pretty (TCrossNode lvl namep r0 r1 r2) - = "TCross" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (TCross1Node lvl namep r0 r1) + = "TCross1" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty namep + pretty (TCross2Node lvl namep r0 r1 r2) + = "TCross2" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty namep - pretty (TEntryNode name opp r0 r1) - = "TEntry" <+> pretty r0 <+> pretty r1 <+> pretty name <+> pretty opp + pretty (TEntryNode r0 r1 r2) + = "TEntry" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (TSplitNode r0 r1 r2) = "TSplit" <+> pretty r0 <+> pretty r1 <+> pretty r2 pretty (TCloseNode r0) = "TClose" <+> pretty r0 @@ -311,9 +327,11 @@ instance Pretty a => Pretty (INetF a) where = "TLeave" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty t pretty (TMatchNode lvl r0 r1 r2 r3) = "TMatch" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty r3 - pretty (PArgumentNode r0 r1 r2) - = "PArgument" <+> pretty r0 <+> pretty r1 <+> pretty r2 + pretty (PArgumentNode t r0 r1 r2) + = "PArgument" <+> pretty r0 <+> pretty r1 <+> pretty r2 <+> pretty t pretty (PReduceNode r0 r1) = "PReduce" <+> pretty r0 <+> pretty r1 + pretty (DupIONode lvl r0 r1 r2) + = "DupIO" <+> pretty lvl <+> pretty r0 <+> pretty r1 <+> pretty r2 instance Ixed (INetF a) where ix idx f = indexing traverse $ Indexed go @@ -474,8 +492,7 @@ reduceNode (AccumIONode ib _ r0) (ReturnCNode _ r1) = do linkNodes r0 $ Ref rn2 1 linkNodes r1 $ Ref rn4 0 reduceNode n0@ReturnCNode {} n1@AccumIONode {} = reduceNode n1 n0 -reduceNode (AccumIONode ib _ r0) (Bind1CNode _ r1 r2) = do - name <- newName +reduceNode (AccumIONode ib _ r0) (Bind1CNode name _ r1 r2) = do rn3 <- newNode $ AccumIONode ib () () rn4 <- newNode $ Bind0FNode name () () () rn5 <- newNode $ PReduceNode () () @@ -506,7 +523,7 @@ reduceNode (AccumNBNode bs _ r0) (NamedBlockNode nbs _) = propagate1 r0 $ IONode $ B._namedBlocks %~ (<>) nbs $ bs reduceNode n0@NamedBlockNode {} n1@AccumNBNode {} = reduceNode n1 n0 reduceNode (OperandANode opp _) (AppNode _ r0 r1) = do - rn2 <- newNode $ PArgumentNode () () () + rn2 <- newNode $ PArgumentNode Nothing () () () propagate1 (Ref rn2 1) $ OperandANode opp linkNodes r0 $ Ref rn2 2 linkNodes r1 $ Ref rn2 0 @@ -516,9 +533,9 @@ reduceNode (OperandPNode opp _ r0) (OperandNode op _) Left opp' -> mkLambda r0 $ OperandPNode opp' Right op' -> propagate1 r0 $ OperandNode op' reduceNode n0@OperandNode {} n1@OperandPNode {} = reduceNode n1 n0 -reduceNode (IOANode iop _) (AppNode _ r0 r1) = do - rn2 <- newNode $ PArgumentNode () () () - propagate1 (Ref rn2 1) $ IOANode iop +reduceNode (IOANode t iop _) (AppNode _ r0 r1) = do + rn2 <- newNode $ PArgumentNode (Just t) () () () + propagate1 (Ref rn2 1) $ IOANode t iop linkNodes r0 $ Ref rn2 2 linkNodes r1 $ Ref rn2 0 reduceNode n0@AppNode {} n1@IOANode {} = reduceNode n1 n0 @@ -527,20 +544,22 @@ reduceNode (IOPNode iop _ r0) (OperandNode op _) Left iop' -> mkLambda r0 $ IOPNode iop' Right instr -> propagate1 r0 $ IOContNode instr reduceNode n0@OperandNode {} n1@IOPNode {} = reduceNode n1 n0 -reduceNode (ReturnFNode _ r0) (OperandNode op _) = propagate1 r0 - $ IONode $ B.BlockList (B.Block mempty $ B.Return op) mempty +reduceNode (ReturnFNode _ r0) (OperandNode op _) + = propagate1 r0 $ IONode $ B.BlockList (B.Block mempty $ B.Return op) mempty reduceNode n0@OperandNode {} n1@ReturnFNode {} = reduceNode n1 n0 +reduceNode (TailCallNode name _ r0) (OperandNode op _) = propagate1 r0 + $ IONode $ B.BlockList (B.Block mempty $ B.TailCall name op) mempty reduceNode (Bind0BNode _ r0) (IOPureNode _ r1) = reassocPure r0 r1 reduceNode n0@IOPureNode {} n1@Bind0BNode {} = reduceNode n1 n0 reduceNode (Bind0BNode _ r0) (IOContNode instr _) = do rn1 <- newNode $ IOContNode instr () - reassocCont r0 $ Ref rn1 0 + reassocCont (B.instrType instr) r0 $ Ref rn1 0 reduceNode n0@IOContNode {} n1@Bind0BNode {} = reduceNode n1 n0 -reduceNode (Bind0BNode _ r0) (PArgumentNode _ r1 r2) = do - rn3 <- newNode $ PArgumentNode () () () +reduceNode (Bind0BNode _ r0) (PArgumentNode (Just t) _ r1 r2) = do + rn3 <- newNode $ PArgumentNode (Just t) () () () linkNodes r1 $ Ref rn3 1 linkNodes r2 $ Ref rn3 2 - reassocCont r0 $ Ref rn3 0 + reassocCont t r0 $ Ref rn3 0 reduceNode n0@PArgumentNode {} n1@Bind0BNode {} = reduceNode n1 n0 reduceNode (Bind0CNode _ r0 r1) (IOPureNode _ r2) = do rn3 <- newNode $ AppNode () () () @@ -549,13 +568,8 @@ reduceNode (Bind0CNode _ r0 r1) (IOPureNode _ r2) = do linkNodes r2 $ Ref rn3 0 reduceNode n0@IOPureNode {} n1@Bind0CNode {} = reduceNode n1 n0 reduceNode (Bind0FNode name _ r0 r1) (IOContNode instr _) = do - let op = B.Reference (B.instrType instr) name rn2 <- newNode $ Bind1FNode (name B.:= instr) () () - rn3 <- newNode $ AppNode () () () - rn4 <- newNode $ OperandNode op () - linkNodes (Ref rn2 1) (Ref rn3 2) - linkNodes (Ref rn3 1) (Ref rn4 0) - linkNodes r0 $ Ref rn3 0 + linkNodes r0 $ Ref rn2 1 linkNodes r1 $ Ref rn2 0 reduceNode n0@IOContNode {} n1@Bind0FNode {} = reduceNode n1 n0 reduceNode (Branch0FNode _ r0 r1 r2) (OperandNode op _) = mkBranch1 op r0 r1 r2 @@ -572,24 +586,67 @@ reduceNode n0@NamedBlockNode {} n1@Merge0Node {} = reduceNode n1 n0 reduceNode (Merge1Node nbs0 _ r0) (NamedBlockNode nbs1 _) = propagate1 r0 $ NamedBlockNode $ nbs0 <> nbs1 reduceNode n0@NamedBlockNode {} n1@Merge1Node {} = reduceNode n1 n0 -reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (OperandNode op _) +reduceNode (TBuild1Node lvl t namep _ r0 r1) (LamNode _ r2 r3) = do + rn4 <- newNode $ TBuild1Node lvl t namep () () () + rn5 <- newNode $ LamNode () () () + linkNodes (Ref rn4 2) (Ref rn5 2) + linkNodes r0 $ Ref rn4 1 + linkNodes r1 $ Ref rn5 0 + linkNodes r2 $ Ref rn5 1 + linkNodes r3 $ Ref rn4 0 +reduceNode n0@LamNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node lvl t namep _ r0 r1 r2) (LamNode _ r3 r4) = do + rn5 <- newNode $ TBuild2Node lvl t namep () () () () + rn6 <- newNode $ LamNode () () () + linkNodes (Ref rn5 3) (Ref rn6 2) + linkNodes r0 $ Ref rn5 1 + linkNodes r1 $ Ref rn5 2 + linkNodes r2 $ Ref rn6 0 + linkNodes r3 $ Ref rn6 1 + linkNodes r4 $ Ref rn5 0 +reduceNode n0@LamNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TBuild1Node _ _ _ _ r0 r1) (OperandNode op _) + = propagate1 r0 TCloseNode *> propagate1 r1 (OperandNode op) +reduceNode n0@OperandNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node _ _ _ _ r0 r1 r2) (OperandNode op _) = propagate2 r0 r1 TCloseNode *> propagate1 r2 (OperandNode op) -reduceNode n0@OperandNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (OperandANode opp _) +reduceNode n0@OperandNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TBuild1Node _ _ _ _ r0 r1) (OperandANode opp _) + = propagate1 r0 TCloseNode *> propagate1 r1 (OperandANode opp) +reduceNode n0@OperandANode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node _ _ _ _ r0 r1 r2) (OperandANode opp _) = propagate2 r0 r1 TCloseNode *> propagate1 r2 (OperandANode opp) -reduceNode n0@OperandANode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (IONode bs _) = do - propagate2 r0 r1 TCloseNode - propagate1 r2 $ IONode bs -reduceNode n0@IONode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (IOANode iop _) - = propagate2 r0 r1 TCloseNode *> propagate1 r2 (IOANode iop) -reduceNode n0@IOANode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (IOContNode instr _) +reduceNode n0@OperandANode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TBuild1Node _ _ _ _ r0 r1) (IONode bs _) + = propagate1 r0 TCloseNode *> propagate1 r1 (IONode bs) +reduceNode n0@IONode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node _ _ _ _ r0 r1 r2) (IONode bs _) + = propagate2 r0 r1 TCloseNode *> propagate1 r2 (IONode bs) +reduceNode n0@IONode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TBuild1Node _ _ _ _ r0 r1) (IOANode t iop _) + = propagate1 r0 TCloseNode *> propagate1 r1 (IOANode t iop) +reduceNode n0@IOANode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node _ _ _ _ r0 r1 r2) (IOANode t iop _) + = propagate2 r0 r1 TCloseNode *> propagate1 r2 (IOANode t iop) +reduceNode n0@IOANode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TBuild1Node _ _ _ _ r0 r1) (IOContNode instr _) + = propagate1 r0 TCloseNode *> propagate1 r1 (IOContNode instr) +reduceNode n0@IOContNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node _ _ _ _ r0 r1 r2) (IOContNode instr _) = propagate2 r0 r1 TCloseNode *> propagate1 r2 (IOContNode instr) -reduceNode n0@IOContNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (ReturnCNode _ r3) = do - rn4 <- newNode $ TBuildNode lvl BuildOperand namep () () () () +reduceNode n0@IOContNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TBuild1Node lvl _ namep _ r0 r1) (ReturnCNode _ r2) = do + rn3 <- newNode $ TBuild1Node lvl BuildOperand namep () () () + rn4 <- newNode $ ReturnFNode () () + rn5 <- newNode $ PReduceNode () () + linkNodes (Ref rn3 2) (Ref rn5 0) + linkNodes (Ref rn4 0) (Ref rn5 1) + linkNodes r0 $ Ref rn3 1 + linkNodes r1 $ Ref rn4 1 + linkNodes r2 $ Ref rn3 0 +reduceNode n0@ReturnCNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node lvl _ namep _ r0 r1 r2) (ReturnCNode _ r3) = do + rn4 <- newNode $ TBuild2Node lvl BuildOperand namep () () () () rn5 <- newNode $ ReturnFNode () () rn6 <- newNode $ PReduceNode () () linkNodes (Ref rn4 3) (Ref rn6 0) @@ -598,11 +655,26 @@ reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (ReturnCNode _ r3) = do linkNodes r1 $ Ref rn4 2 linkNodes r2 $ Ref rn5 1 linkNodes r3 $ Ref rn4 0 -reduceNode n0@ReturnCNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Bind1CNode _ r3 r4) = do - name <- newName - rn5 <- newNode $ TBuildNode lvl BuildOperand namep () () () () - rn6 <- newNode $ TBuildNode lvl BuildIO namep () () () () +reduceNode n0@ReturnCNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TBuild1Node lvl _ namep _ r0 r1) (Bind1CNode name _ r2 r3) = do + rn4 <- newNode $ TBuild1Node lvl BuildOperand namep () () () + rn5 <- newNode $ TBuild1Node lvl BuildIO namep () () () + rn6 <- newNode $ Bind0FNode name () () () + rn7 <- newNode $ TSplitNode () () () + rn8 <- newNode $ PReduceNode () () + linkNodes (Ref rn4 1) (Ref rn7 1) + linkNodes (Ref rn4 2) (Ref rn8 0) + linkNodes (Ref rn5 1) (Ref rn7 2) + linkNodes (Ref rn5 2) (Ref rn6 1) + linkNodes (Ref rn6 0) (Ref rn8 1) + linkNodes r0 $ Ref rn7 0 + linkNodes r1 $ Ref rn6 2 + linkNodes r2 $ Ref rn4 0 + linkNodes r3 $ Ref rn5 0 +reduceNode n0@Bind1CNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node lvl _ namep _ r0 r1 r2) (Bind1CNode name _ r3 r4) = do + rn5 <- newNode $ TBuild2Node lvl BuildOperand namep () () () () + rn6 <- newNode $ TBuild2Node lvl BuildIO namep () () () () rn7 <- newNode $ Bind0FNode name () () () rn8 <- newNode $ TSplitNode () () () rn9 <- newNode $ TSplitNode () () () @@ -612,27 +684,55 @@ reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Bind1CNode _ r3 r4) = do linkNodes (Ref rn5 3) (Ref rn10 0) linkNodes (Ref rn6 1) (Ref rn8 2) linkNodes (Ref rn6 2) (Ref rn9 2) - linkNodes (Ref rn6 0) (Ref rn7 2) + linkNodes (Ref rn6 3) (Ref rn7 1) linkNodes (Ref rn7 0) (Ref rn10 1) linkNodes r0 $ Ref rn8 0 linkNodes r1 $ Ref rn9 0 - linkNodes r2 $ Ref rn6 3 + linkNodes r2 $ Ref rn7 2 linkNodes r3 $ Ref rn5 0 - linkNodes r4 $ Ref rn7 1 -reduceNode n0@Bind1CNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Bind1FNode instr _ r3) = do - rn4 <- newNode $ TBuildNode lvl BuildIO namep () () () () + linkNodes r4 $ Ref rn6 0 +reduceNode n0@Bind1CNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TBuild1Node lvl _ namep _ r0 r1) (Bind1FNode instr _ r2) = do + rn3 <- newNode $ TBuild1Node lvl BuildIO namep () () () + rn4 <- newNode $ Bind1FNode instr () () + linkNodes (Ref rn3 2) (Ref rn4 1) + linkNodes r0 $ Ref rn3 1 + linkNodes r1 $ Ref rn4 0 + linkNodes r2 $ Ref rn3 0 +reduceNode n0@Bind1FNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node lvl _ namep _ r0 r1 r2) (Bind1FNode instr _ r3) = do + rn4 <- newNode $ TBuild2Node lvl BuildIO namep () () () () rn5 <- newNode $ Bind1FNode instr () () linkNodes (Ref rn4 3) (Ref rn5 1) linkNodes r0 $ Ref rn4 1 linkNodes r1 $ Ref rn4 2 linkNodes r2 $ Ref rn5 0 linkNodes r3 $ Ref rn4 0 -reduceNode n0@Bind1FNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Branch0CNode _ r3 r4 r5) = do - rn6 <- newNode $ TBuildNode lvl BuildOperand namep () () () () - rn7 <- newNode $ TBuildNode lvl BuildIO namep () () () () - rn8 <- newNode $ TBuildNode lvl BuildIO namep () () () () +reduceNode n0@Bind1FNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TBuild1Node lvl _ namep _ r0 r1) (Branch0CNode _ r2 r3 r4) = do + rn5 <- newNode $ TBuild1Node lvl BuildOperand namep () () () + rn6 <- newNode $ TBuild1Node lvl BuildIO namep () () () + rn7 <- newNode $ TBuild1Node lvl BuildIO namep () () () + rn8 <- newNode $ Branch0CNode () () () () + rn9 <- newNode $ TSplitNode () () () + rn10 <- newNode $ TSplitNode () () () + linkNodes (Ref rn5 1) (Ref rn9 1) + linkNodes (Ref rn5 2) (Ref rn8 1) + linkNodes (Ref rn6 1) (Ref rn10 1) + linkNodes (Ref rn6 2) (Ref rn8 2) + linkNodes (Ref rn7 1) (Ref rn10 2) + linkNodes (Ref rn7 2) (Ref rn8 3) + linkNodes (Ref rn9 2) (Ref rn10 0) + linkNodes r0 $ Ref rn9 0 + linkNodes r1 $ Ref rn8 0 + linkNodes r2 $ Ref rn5 0 + linkNodes r3 $ Ref rn6 0 + linkNodes r4 $ Ref rn7 0 +reduceNode n0@Branch0CNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node lvl _ namep _ r0 r1 r2) (Branch0CNode _ r3 r4 r5) = do + rn6 <- newNode $ TBuild2Node lvl BuildOperand namep () () () () + rn7 <- newNode $ TBuild2Node lvl BuildIO namep () () () () + rn8 <- newNode $ TBuild2Node lvl BuildIO namep () () () () rn9 <- newNode $ Branch0CNode () () () () rn10 <- newNode $ TSplitNode () () () rn11 <- newNode $ TSplitNode () () () @@ -655,11 +755,25 @@ reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (Branch0CNode _ r3 r4 r5) = do linkNodes r3 $ Ref rn6 0 linkNodes r4 $ Ref rn7 0 linkNodes r5 $ Ref rn8 0 -reduceNode n0@Branch0CNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (PArgumentNode _ r3 r4) = do - rn5 <- newNode $ TBuildNode lvl BuildOperand namep () () () () - rn6 <- newNode $ TBuildNode lvl BuildOperand namep () () () () - rn7 <- newNode $ PArgumentNode () () () +reduceNode n0@Branch0CNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TBuild1Node lvl _ namep _ r0 r1) (PArgumentNode t _ r2 r3) = do + rn4 <- newNode $ TBuild1Node lvl BuildOperand namep () () () + rn5 <- newNode $ TBuild1Node lvl BuildOperand namep () () () + rn6 <- newNode $ PArgumentNode t () () () + rn7 <- newNode $ TSplitNode () () () + linkNodes (Ref rn4 1) (Ref rn7 1) + linkNodes (Ref rn4 2) (Ref rn6 1) + linkNodes (Ref rn5 1) (Ref rn7 2) + linkNodes (Ref rn5 2) (Ref rn6 2) + linkNodes r0 $ Ref rn7 0 + linkNodes r1 $ Ref rn6 0 + linkNodes r2 $ Ref rn4 0 + linkNodes r3 $ Ref rn5 0 +reduceNode n0@PArgumentNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node lvl _ namep _ r0 r1 r2) (PArgumentNode t _ r3 r4) = do + rn5 <- newNode $ TBuild2Node lvl BuildOperand namep () () () () + rn6 <- newNode $ TBuild2Node lvl BuildOperand namep () () () () + rn7 <- newNode $ PArgumentNode t () () () rn8 <- newNode $ TSplitNode () () () rn9 <- newNode $ TSplitNode () () () linkNodes (Ref rn5 1) (Ref rn8 1) @@ -673,47 +787,82 @@ reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (PArgumentNode _ r3 r4) = do linkNodes r2 $ Ref rn7 0 linkNodes r3 $ Ref rn5 0 linkNodes r4 $ Ref rn6 0 -reduceNode n0@PArgumentNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (AccumIONode ib _ r0) (TEntryNode name opp _ r1) = do - let term = B.TailCall name opp - propagate1 r0 $ IONode $ B.BlockList (B.Block (B.unIBlock ib) term) mempty +reduceNode n0@PArgumentNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (AccumIONode ib _ r0) (TEntryNode _ r1 r2) = do + rn3 <- newNode $ AccumIONode ib () () + linkNodes r0 $ Ref rn3 1 propagate1 r1 TCloseNode + linkNodes r2 $ Ref rn3 0 reduceNode n0@TEntryNode {} n1@AccumIONode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl _ namep _ r0 r1 r2) (TEntryNode name opp _ r3) = do - let term = B.TailCall name opp - rn4 <- newNode $ TCrossNode lvl namep () () () - propagate1 r2 $ IONode $ B.BlockList (B.Block mempty term) mempty +reduceNode (TBuild1Node lvl _ namep _ r0 r1) (TEntryNode _ r2 r3) = do + rn4 <- newNode $ TCross1Node lvl namep () () linkNodes r0 $ Ref rn4 1 - linkNodes r1 $ Ref rn4 2 - linkNodes r3 $ Ref rn4 0 -reduceNode n0@TEntryNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TCrossNode lvl namep _ r0 r1) (TSplitNode _ r2 r3) - = commute2 (TCrossNode lvl namep) TSplitNode r0 r1 r2 r3 -reduceNode n0@TSplitNode {} n1@TCrossNode {} = reduceNode n1 n0 -reduceNode (TCrossNode _ _ _ r0 r1) (TCloseNode _) = propagate2 r0 r1 TCloseNode -reduceNode n0@TCloseNode {} n1@TCrossNode {} = reduceNode n1 n0 + linkNodes r1 r3 + linkNodes r2 $ Ref rn4 0 +reduceNode n0@TEntryNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node lvl _ namep _ r0 r1 r2) (TEntryNode _ r3 r4) = do + rn5 <- newNode $ TCross2Node lvl namep () () () + linkNodes r0 $ Ref rn5 1 + linkNodes r1 $ Ref rn5 2 + linkNodes r2 r4 + linkNodes r3 $ Ref rn5 0 +reduceNode n0@TEntryNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TSplitNode _ r0 r1) (TCross1Node lvl namep _ r2) + = commute1 TSplitNode (TCross1Node lvl namep) r0 r1 r2 +reduceNode n0@TCross1Node {} n1@TSplitNode {} = reduceNode n1 n0 +reduceNode (TCross2Node lvl namep _ r0 r1) (TSplitNode _ r2 r3) + = commute2 (TCross2Node lvl namep) TSplitNode r0 r1 r2 r3 +reduceNode n0@TSplitNode {} n1@TCross2Node {} = reduceNode n1 n0 +reduceNode (TCross1Node _ _ _ r0) (TCloseNode _) = propagate1 r0 TCloseNode +reduceNode n0@TCloseNode {} n1@TCross1Node {} = reduceNode n1 n0 +reduceNode (TCross2Node _ _ _ r0 r1) (TCloseNode _) + = propagate2 r0 r1 TCloseNode +reduceNode n0@TCloseNode {} n1@TCross2Node {} = reduceNode n1 n0 reduceNode (TSplitNode _ r0 r1) (TCloseNode _) = propagate2 r0 r1 TCloseNode reduceNode n0@TCloseNode {} n1@TSplitNode {} = reduceNode n1 n0 reduceNode (TCloseNode _) (TCloseNode _) = pure () -reduceNode (TCrossNode lvl namep _ r0 r1) (TLeaveNode t _ r2 r3) = do - rn4 <- newNode $ TBuildNode lvl t namep () () () () +reduceNode (TCross1Node lvl namep _ r0) (TLeaveNode t _ r1 r2) = do + rn3 <- newNode $ TBuild1Node lvl t namep () () () + linkNodes r0 $ Ref rn3 1 + linkNodes r1 $ Ref rn3 0 + linkNodes r2 $ Ref rn3 2 +reduceNode n0@TLeaveNode {} n1@TCross1Node {} = reduceNode n1 n0 +reduceNode (TCross2Node lvl namep _ r0 r1) (TLeaveNode t _ r2 r3) = do + rn4 <- newNode $ TBuild2Node lvl t namep () () () () linkNodes r0 $ Ref rn4 1 linkNodes r1 $ Ref rn4 2 linkNodes r2 $ Ref rn4 0 linkNodes r3 $ Ref rn4 3 -reduceNode n0@TLeaveNode {} n1@TCrossNode {} = reduceNode n1 n0 +reduceNode n0@TLeaveNode {} n1@TCross2Node {} = reduceNode n1 n0 reduceNode (TLeaveNode _ _ r0 r1) (TCloseNode _) = linkNodes r0 r1 reduceNode n0@TCloseNode {} n1@TLeaveNode {} = reduceNode n1 n0 -reduceNode (TCrossNode lvl0 namep _ r0 r1) (TMatchNode lvl1 _ r2 r3 r4) +reduceNode (TCross1Node lvl0 namep _ r0) (TMatchNode lvl1 _ r1 r2 r3) + | lvl0 == lvl1 = do + rn4 <- newNode $ TSplitNode () () () + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn4 1 + linkNodes r2 $ Ref rn4 2 + propagate1 r3 $ OperandNode namep + | otherwise = do + rn4 <- newNode $ TCross1Node lvl0 namep () () + rn5 <- newNode $ TCross1Node lvl0 namep () () + rn6 <- newNode $ TMatchNode lvl1 () () () () + linkNodes (Ref rn4 1) (Ref rn6 1) + linkNodes (Ref rn5 1) (Ref rn6 2) + linkNodes r0 $ Ref rn6 0 + linkNodes r1 $ Ref rn4 0 + linkNodes r2 $ Ref rn5 0 + linkNodes r3 $ Ref rn6 3 +reduceNode n0@TMatchNode {} n1@TCross1Node {} = reduceNode n1 n0 +reduceNode (TCross2Node lvl0 namep _ r0 r1) (TMatchNode lvl1 _ r2 r3 r4) | lvl0 == lvl1 = do linkNodes r0 r2 linkNodes r1 r3 - propagate1 r4 $ OperandNode $ B.Reference (B.IntType 1) namep + propagate1 r4 $ OperandNode namep | otherwise = do - let opp = B.Partial (SSucc $ SSucc SZero) $ mkSelect - $ B.Reference (B.IntType 1) namep - rn5 <- newNode $ TCrossNode lvl0 namep () () () - rn6 <- newNode $ TCrossNode lvl0 namep () () () + let opp = B.Partial (SSucc $ SSucc SZero) $ mkSelect namep + rn5 <- newNode $ TCross2Node lvl0 namep () () () + rn6 <- newNode $ TCross2Node lvl0 namep () () () rn7 <- newNode $ TMatchNode lvl1 () () () () rn8 <- newNode $ TMatchNode lvl1 () () () () rn9 <- newNode $ OperandPNode opp () () @@ -730,17 +879,22 @@ reduceNode (TCrossNode lvl0 namep _ r0 r1) (TMatchNode lvl1 _ r2 r3 r4) linkNodes r2 $ Ref rn5 0 linkNodes r3 $ Ref rn6 0 linkNodes r4 $ Ref rn10 2 -reduceNode n0@TMatchNode {} n1@TCrossNode {} = reduceNode n1 n0 -reduceNode (PArgumentNode _ r0 r1) (AppNode _ r2 r3) = do - rn4 <- newNode $ PArgumentNode () () () - rn5 <- newNode $ PArgumentNode () () () +reduceNode n0@TMatchNode {} n1@TCross2Node {} = reduceNode n1 n0 +reduceNode (TCloseNode _) (TMatchNode _ _ r0 r1 r2) + = propagate2 r0 r1 TCloseNode *> propagate1 r2 (OperandNode opUndef) + where + opUndef = B.Reference (B.IntType 1) $ B.Name $ -1 +reduceNode n0@TMatchNode {} n1@TCloseNode {} = reduceNode n1 n0 +reduceNode (PArgumentNode t _ r0 r1) (AppNode _ r2 r3) = do + rn4 <- newNode $ PArgumentNode t () () () + rn5 <- newNode $ PArgumentNode t () () () linkNodes (Ref rn4 0) (Ref rn5 1) linkNodes r0 $ Ref rn4 1 linkNodes r1 $ Ref rn4 2 linkNodes r2 $ Ref rn5 2 linkNodes r3 $ Ref rn5 0 reduceNode n0@AppNode {} n1@PArgumentNode {} = reduceNode n1 n0 -reduceNode (PArgumentNode _ r0 r1) (OperandPNode opp _ r2) = do +reduceNode (PArgumentNode _ _ r0 r1) (OperandPNode opp _ r2) = do rn3 <- newNode $ AppNode () () () rn4 <- newNode $ PReduceNode () () rn5 <- newNode $ PReduceNode () () @@ -752,7 +906,7 @@ reduceNode (PArgumentNode _ r0 r1) (OperandPNode opp _ r2) = do linkNodes r1 $ Ref rn5 0 linkNodes r2 $ Ref rn6 1 reduceNode n0@OperandPNode {} n1@PArgumentNode {} = reduceNode n1 n0 -reduceNode (PArgumentNode _ r0 r1) (IOPNode iop _ r2) = do +reduceNode (PArgumentNode _ _ r0 r1) (IOPNode iop _ r2) = do rn3 <- newNode $ AppNode () () () rn4 <- newNode $ PReduceNode () () rn5 <- newNode $ PReduceNode () () @@ -764,7 +918,7 @@ reduceNode (PArgumentNode _ r0 r1) (IOPNode iop _ r2) = do linkNodes r1 $ Ref rn5 0 linkNodes r2 $ Ref rn6 1 reduceNode n0@IOPNode {} n1@PArgumentNode {} = reduceNode n1 n0 -reduceNode (PArgumentNode _ r0 r1) (PReduceNode _ r2) = do +reduceNode (PArgumentNode _ _ r0 r1) (PReduceNode _ r2) = do rn3 <- newNode $ AppNode () () () rn4 <- newNode $ PReduceNode () () rn5 <- newNode $ PReduceNode () () @@ -780,7 +934,7 @@ reduceNode n0@OperandNode {} n1@PReduceNode {} = reduceNode n1 n0 reduceNode (PReduceNode _ r0) (OperandANode opp _) = mkLambda r0 $ OperandPNode opp reduceNode n0@OperandANode {} n1@PReduceNode {} = reduceNode n1 n0 -reduceNode (PReduceNode _ r0) (IOANode iop _) = mkLambda r0 $ IOPNode iop +reduceNode (PReduceNode _ r0) (IOANode _ iop _) = mkLambda r0 $ IOPNode iop reduceNode n0@IOANode {} n1@PReduceNode {} = reduceNode n1 n0 reduceNode (PReduceNode _ r0) (IOContNode instr _) = propagate1 r0 $ IOContNode instr @@ -799,7 +953,8 @@ reduceNode (DupNode lvl _ r0 r1) (IONode bs _) = do rn2 <- newNode $ IONode bs () dedupIO lvl r0 r1 $ Ref rn2 0 reduceNode n0@IONode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode _ _ r0 r1) (IOANode iop _) = propagate2 r0 r1 $ IOANode iop +reduceNode (DupNode _ _ r0 r1) (IOANode t iop _) + = propagate2 r0 r1 $ IOANode t iop reduceNode n0@IOANode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (IOPNode iop _ r2) = commute1 (DupNode lvl) (IOPNode iop) r0 r1 r2 @@ -815,18 +970,29 @@ reduceNode (DupNode lvl _ r0 r1) (ReturnCNode _ r2) = do linkNodes r2 $ Ref rn3 1 dedupIO lvl r0 r1 $ Ref rn3 0 reduceNode n0@ReturnCNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupIONode lvl _ r0 r1) (ReturnCNode _ r2) = do + rn3 <- newNode $ ReturnCNode () () + linkNodes r2 $ Ref rn3 1 + dedupIO' lvl r0 r1 $ Ref rn3 0 +reduceNode n0@ReturnCNode {} n1@DupIONode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (Bind0BNode _ r2) = commute1 (DupNode lvl) Bind0BNode r0 r1 r2 reduceNode n0@Bind0BNode {} n1@DupNode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (Bind0CNode _ r2 r3) = commute2 (DupNode lvl) Bind0CNode r0 r1 r2 r3 reduceNode n0@Bind0CNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl _ r0 r1) (Bind1CNode _ r2 r3) = do - rn4 <- newNode $ Bind1CNode () () () +reduceNode (DupNode lvl _ r0 r1) (Bind1CNode name _ r2 r3) = do + rn4 <- newNode $ Bind1CNode name () () () linkNodes r2 $ Ref rn4 1 linkNodes r3 $ Ref rn4 2 dedupIO lvl r0 r1 $ Ref rn4 0 reduceNode n0@Bind1CNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupIONode lvl _ r0 r1) (Bind1CNode name _ r2 r3) = do + rn4 <- newNode $ Bind1CNode name () () () + linkNodes r2 $ Ref rn4 1 + linkNodes r3 $ Ref rn4 2 + dedupIO' lvl r0 r1 $ Ref rn4 0 +reduceNode n0@Bind1CNode {} n1@DupIONode {} = reduceNode n1 n0 reduceNode (DupNode lvl _ r0 r1) (Branch0CNode _ r2 r3 r4) = do rn5 <- newNode $ Branch0CNode () () () () linkNodes r2 $ Ref rn5 1 @@ -834,9 +1000,56 @@ reduceNode (DupNode lvl _ r0 r1) (Branch0CNode _ r2 r3 r4) = do linkNodes r4 $ Ref rn5 3 dedupIO lvl r0 r1 $ Ref rn5 0 reduceNode n0@Branch0CNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl0 _ r0 r1) (TBuildNode lvl1 t namep _ r2 r3 r4) +reduceNode (DupNode lvl0 _ r0 r1) (TBuild1Node lvl1 t opp _ r2 r3) + | lvl0 == lvl1 = do + rn4 <- newNode $ TSplitNode () () () + rn5 <- newNode $ TLeaveNode t () () () + rn6 <- newNode $ TLeaveNode t () () () + linkNodes (Ref rn4 1) (Ref rn5 0) + linkNodes (Ref rn4 2) (Ref rn6 0) + linkNodes r0 $ Ref rn5 1 + linkNodes r1 $ Ref rn6 1 + linkNodes r2 $ Ref rn4 0 + case t of + BuildOperand -> do + let opp' = B.Partial (SSucc $ SSucc SZero) $ mkSelect opp + rn7 <- newNode $ OperandPNode opp' () () + rn8 <- newNode $ AppNode () () () + linkNodes (Ref rn5 2) (Ref rn7 0) + linkNodes (Ref rn6 2) (Ref rn8 1) + linkNodes (Ref rn7 1) (Ref rn8 0) + linkNodes r3 $ Ref rn8 2 + BuildIO -> mkBranch1 opp (Ref rn5 2) (Ref rn6 2) r3 + | otherwise = do + rn4 <- newNode $ TMatchNode lvl0 () () () () + rn5 <- newNode $ TBuild1Node lvl1 t opp () () () + rn6 <- newNode $ TBuild1Node lvl1 t opp () () () + linkNodes (Ref rn4 1) (Ref rn5 1) + linkNodes (Ref rn4 2) (Ref rn6 1) + linkNodes r0 $ Ref rn5 0 + linkNodes r1 $ Ref rn6 0 + linkNodes r2 $ Ref rn4 0 + case t of + BuildOperand -> do + let opp' = B.Partial (SSucc $ SSucc $ SSucc SZero) mkSelect + rn7 <- newNode $ OperandPNode opp' () () + rn8 <- newNode $ AppNode () () () + rn9 <- newNode $ AppNode () () () + linkNodes (Ref rn7 0) (Ref rn4 3) + linkNodes (Ref rn7 1) (Ref rn8 0) + linkNodes (Ref rn8 1) (Ref rn5 2) + linkNodes (Ref rn8 2) (Ref rn9 0) + linkNodes (Ref rn9 1) (Ref rn6 2) + linkNodes r3 $ Ref rn9 2 + BuildIO -> do + rn7 <- newNode $ Branch0CNode () () () () + linkNodes (Ref rn4 3) (Ref rn7 1) + linkNodes (Ref rn5 2) (Ref rn7 2) + linkNodes (Ref rn6 2) (Ref rn7 3) + linkNodes r3 $ Ref rn7 0 +reduceNode n0@TBuild1Node {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 _ r0 r1) (TBuild2Node lvl1 t opp _ r2 r3 r4) | lvl0 == lvl1 = do - let opp = B.Reference (B.IntType 1) namep rn5 <- newNode $ TLeaveNode t () () () rn6 <- newNode $ TLeaveNode t () () () linkNodes r0 $ Ref rn5 1 @@ -854,14 +1067,13 @@ reduceNode (DupNode lvl0 _ r0 r1) (TBuildNode lvl1 t namep _ r2 r3 r4) linkNodes r4 $ Ref rn8 2 BuildIO -> mkBranch1 opp (Ref rn5 2) (Ref rn6 2) r4 | otherwise = do - let opp = B.Partial (SSucc $ SSucc SZero) - $ mkSelect $ B.Reference (B.IntType 1) namep - rn3 <- newNode $ OperandPNode opp () () + let opp' = B.Partial (SSucc $ SSucc SZero) $ mkSelect opp + rn3 <- newNode $ OperandPNode opp' () () rn4 <- newNode $ AppNode () () () rn5 <- newNode $ TMatchNode lvl0 () () () () rn6 <- newNode $ TMatchNode lvl0 () () () () - rn7 <- newNode $ TBuildNode lvl1 t namep () () () () - rn8 <- newNode $ TBuildNode lvl1 t namep () () () () + rn7 <- newNode $ TBuild2Node lvl1 t opp () () () () + rn8 <- newNode $ TBuild2Node lvl1 t opp () () () () linkNodes (Ref rn3 0) (Ref rn5 3) linkNodes (Ref rn3 1) (Ref rn4 0) linkNodes (Ref rn4 1) (Ref rn6 3) @@ -875,8 +1087,8 @@ reduceNode (DupNode lvl0 _ r0 r1) (TBuildNode lvl1 t namep _ r2 r3 r4) linkNodes r3 $ Ref rn6 0 case t of BuildOperand -> do - let opp' = B.Partial (SSucc $ SSucc $ SSucc SZero) mkSelect - rn2 <- newNode $ OperandPNode opp' () () + let opp'' = B.Partial (SSucc $ SSucc $ SSucc SZero) mkSelect + rn2 <- newNode $ OperandPNode opp'' () () rn9 <- newNode $ AppNode () () () rn10 <- newNode $ AppNode () () () linkNodes (Ref rn2 0) (Ref rn4 2) @@ -891,35 +1103,60 @@ reduceNode (DupNode lvl0 _ r0 r1) (TBuildNode lvl1 t namep _ r2 r3 r4) linkNodes (Ref rn2 2) (Ref rn7 3) linkNodes (Ref rn2 3) (Ref rn8 3) linkNodes r4 $ Ref rn2 0 -reduceNode n0@TBuildNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl _ r0 r1) (TEntryNode name opp _ r2) = do - rn3 <- newNode $ TEntryNode name opp () () - linkNodes r2 $ Ref rn3 1 - dedupIO lvl r0 r1 $ Ref rn3 0 +reduceNode n0@TBuild2Node {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (TEntryNode _ r2 r3) = do + rn4 <- newNode $ TEntryNode () () () + linkNodes r2 $ Ref rn4 1 + linkNodes r3 $ Ref rn4 2 + dedupIO lvl r0 r1 $ Ref rn4 0 reduceNode n0@TEntryNode {} n1@DupNode {} = reduceNode n1 n0 -reduceNode (DupNode lvl _ r0 r1) (PArgumentNode _ r2 r3) - = commute2 (DupNode lvl) PArgumentNode r0 r1 r2 r3 +reduceNode (DupIONode lvl _ r0 r1) (TEntryNode _ r2 r3) = do + rn4 <- newNode $ TEntryNode () () () + linkNodes r2 $ Ref rn4 1 + linkNodes r3 $ Ref rn4 2 + dedupIO' lvl r0 r1 $ Ref rn4 0 +reduceNode n0@TEntryNode {} n1@DupIONode {} = reduceNode n1 n0 +reduceNode (DupNode lvl _ r0 r1) (PArgumentNode t _ r2 r3) + = commute2 (DupNode lvl) (PArgumentNode t) r0 r1 r2 r3 reduceNode n0@PArgumentNode {} n1@DupNode {} = reduceNode n1 n0 +reduceNode (DupNode lvl0 _ r0 r1) (DupIONode lvl1 _ r2 r3) + | lvl0 == lvl1 = do + rn4 <- newNode $ DupNode lvl0 () () () + linkNodes r0 $ Ref rn4 1 + linkNodes r1 $ Ref rn4 2 + dedupIO' lvl1 r2 r3 $ Ref rn4 0 + | otherwise = commute2 (DupNode lvl0) (DupIONode lvl1) r0 r1 r2 r3 +reduceNode n0@DupIONode {} n1@DupNode {} = reduceNode n1 n0 -- FFI Dead reduceNode (AccumIONode ib _ r0) (DeadNode _) = propagate1 r0 $ IONode $ B.BlockList (B.Block (B.unIBlock ib) B.Unreachable) mempty reduceNode n0@DeadNode {} n1@AccumIONode {} = reduceNode n1 n0 reduceNode (OperandNode _ _) (DeadNode _) = pure () reduceNode n0@DeadNode {} n1@OperandNode {} = reduceNode n1 n0 +reduceNode (OperandANode _ _) (DeadNode _) = pure () +reduceNode n0@DeadNode {} n1@OperandANode {} = reduceNode n1 n0 reduceNode (OperandPNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@OperandPNode {} = reduceNode n1 n0 reduceNode (IONode _ _) (DeadNode _) = pure () reduceNode n0@DeadNode {} n1@IONode {} = reduceNode n1 n0 +reduceNode (IOANode _ _ _) (DeadNode _) = pure () +reduceNode n0@DeadNode {} n1@IOANode {} = reduceNode n1 n0 reduceNode (IOPNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@IOPNode {} = reduceNode n1 n0 reduceNode (IOPureNode _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@IOPureNode {} = reduceNode n1 n0 reduceNode (IOContNode _ _) (DeadNode _) = pure () reduceNode n0@DeadNode {} n1@IOContNode {} = reduceNode n1 n0 +reduceNode (TailCallNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@TailCallNode {} = reduceNode n1 n0 reduceNode (Bind0BNode _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@Bind0BNode {} = reduceNode n1 n0 reduceNode (Bind0CNode _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode reduceNode n0@DeadNode {} n1@Bind0CNode {} = reduceNode n1 n0 +reduceNode (Bind0FNode _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode n0@DeadNode {} n1@Bind0FNode {} = reduceNode n1 n0 +reduceNode (Bind1CNode _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode n0@DeadNode {} n1@Bind1CNode {} = reduceNode n1 n0 reduceNode (Bind1FNode _ _ r0) (DeadNode _) = propagate1 r0 DeadNode reduceNode n0@DeadNode {} n1@Bind1FNode {} = reduceNode n1 n0 reduceNode (LabelNode lbl _ r0) (DeadNode _) @@ -928,11 +1165,21 @@ reduceNode (LabelNode lbl _ r0) (DeadNode _) reduceNode n0@DeadNode {} n1@LabelNode {} = reduceNode n1 n0 reduceNode (NamedBlockNode _ _) (DeadNode _) = pure () reduceNode n0@DeadNode {} n1@NamedBlockNode {} = reduceNode n1 n0 -reduceNode (TBuildNode _ _ _ _ r0 r1 r2) (DeadNode _) +reduceNode (TBuild1Node _ _ _ _ r0 r1) (DeadNode _) + = propagate1 r0 TCloseNode *> propagate1 r1 DeadNode +reduceNode n0@DeadNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node _ _ _ _ r0 r1 r2) (DeadNode _) = propagate2 r0 r1 TCloseNode *> propagate1 r2 DeadNode -reduceNode n0@DeadNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TEntryNode _ _ _ r0) (DeadNode _) = propagate1 r0 TCloseNode +reduceNode n0@DeadNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TEntryNode _ r0 r1) (DeadNode _) + = propagate1 r0 TCloseNode *> propagate1 r1 DeadNode reduceNode n0@DeadNode {} n1@TEntryNode {} = reduceNode n1 n0 +reduceNode (PArgumentNode _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode n0@DeadNode {} n1@PArgumentNode {} = reduceNode n1 n0 +reduceNode (PReduceNode _ r0) (DeadNode _) = propagate1 r0 DeadNode +reduceNode n0@DeadNode {} n1@PReduceNode {} = reduceNode n1 n0 +reduceNode (DupIONode _ _ r0 r1) (DeadNode _) = propagate2 r0 r1 DeadNode +reduceNode n0@DeadNode {} n1@DupIONode {} = reduceNode n1 n0 -- FFI Book-keeping reduceNode (AccumIONode ib _ r0) (BoxNode _ _ r1) = do rn2 <- newNode $ AccumIONode ib () () @@ -949,7 +1196,7 @@ reduceNode (OperandPNode opp _ r0) (BoxNode lvl _ r1) reduceNode n0@BoxNode {} n1@OperandPNode {} = reduceNode n1 n0 reduceNode (IONode b _) (BoxNode _ _ r0) = propagate1 r0 $ IONode b reduceNode n0@BoxNode {} n1@IONode {} = reduceNode n1 n0 -reduceNode (IOANode iop _) (BoxNode _ _ r0) = propagate1 r0 $ IOANode iop +reduceNode (IOANode t iop _) (BoxNode _ _ r0) = propagate1 r0 $ IOANode t iop reduceNode n0@BoxNode {} n1@IOANode {} = reduceNode n1 n0 reduceNode (IOPNode iop _ r0) (BoxNode lvl _ r1) = commute0 (IOPNode iop) (BoxNode lvl) r0 r1 @@ -966,6 +1213,9 @@ reduceNode n0@BoxNode {} n1@ReturnCNode {} = reduceNode n1 n0 reduceNode (ReturnFNode _ r0) (BoxNode lvl _ r1) = commute0 ReturnFNode (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@ReturnFNode {} = reduceNode n1 n0 +reduceNode (TailCallNode name _ r0) (BoxNode lvl _ r1) + = commute0 (TailCallNode name) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@TailCallNode {} = reduceNode n1 n0 reduceNode (Bind0BNode _ r0) (BoxNode lvl _ r1) = commute0 Bind0BNode (BoxNode lvl) r0 r1 reduceNode n0@BoxNode {} n1@Bind0BNode {} = reduceNode n1 n0 @@ -975,8 +1225,8 @@ reduceNode n0@BoxNode {} n1@Bind0CNode {} = reduceNode n1 n0 reduceNode (Bind0FNode name _ r0 r1) (BoxNode lvl _ r2) = commute1 (Bind0FNode name) (BoxNode lvl) r0 r1 r2 reduceNode n0@BoxNode {} n1@Bind0FNode {} = reduceNode n1 n0 -reduceNode (Bind1CNode _ r0 r1) (BoxNode lvl _ r2) - = commute1 Bind1CNode (BoxNode lvl) r0 r1 r2 +reduceNode (Bind1CNode name _ r0 r1) (BoxNode lvl _ r2) + = commute1 (Bind1CNode name) (BoxNode lvl) r0 r1 r2 reduceNode n0@BoxNode {} n1@Bind1CNode {} = reduceNode n1 n0 reduceNode (Bind1FNode nbs _ r0) (BoxNode lvl _ r1) = commute0 (Bind1FNode nbs) (BoxNode lvl) r0 r1 @@ -993,9 +1243,18 @@ reduceNode (LabelNode lbl _ r0) (BoxNode _ _ r1) linkNodes r0 $ Ref rn2 1 linkNodes r1 $ Ref rn2 0 reduceNode n0@BoxNode {} n1@LabelNode {} = reduceNode n1 n0 -reduceNode (TBuildNode lvl0 t namep _ r0 r1 r2) (BoxNode lvl1 _ r3) = do +reduceNode (TBuild1Node lvl0 t namep _ r0 r1) (BoxNode lvl1 _ r2) = do + let lvl0' = if lvl0 < lvl1 then lvl0 else succ lvl0 + rn3 <- newNode $ TBuild1Node lvl0' t namep () () () + rn4 <- newNode $ BoxNode lvl1 () () + linkNodes (Ref rn3 1) (Ref rn4 1) + linkNodes r0 $ Ref rn4 0 + linkNodes r1 $ Ref rn3 2 + linkNodes r2 $ Ref rn3 0 +reduceNode n0@BoxNode {} n1@TBuild1Node {} = reduceNode n1 n0 +reduceNode (TBuild2Node lvl0 t namep _ r0 r1 r2) (BoxNode lvl1 _ r3) = do let lvl0' = if lvl0 < lvl1 then lvl0 else succ lvl0 - rn4 <- newNode $ TBuildNode lvl0' t namep () () () () + rn4 <- newNode $ TBuild2Node lvl0' t namep () () () () rn5 <- newNode $ BoxNode lvl1 () () rn6 <- newNode $ BoxNode lvl1 () () linkNodes (Ref rn4 1) (Ref rn5 1) @@ -1004,14 +1263,19 @@ reduceNode (TBuildNode lvl0 t namep _ r0 r1 r2) (BoxNode lvl1 _ r3) = do linkNodes r1 $ Ref rn6 0 linkNodes r2 $ Ref rn4 3 linkNodes r3 $ Ref rn4 0 -reduceNode n0@BoxNode {} n1@TBuildNode {} = reduceNode n1 n0 -reduceNode (TCrossNode lvl0 namep _ r0 r1) (BoxNode lvl1 _ r2) = commute1 - (TCrossNode (if lvl0 < lvl1 then lvl0 else succ lvl0) namep) +reduceNode n0@BoxNode {} n1@TBuild2Node {} = reduceNode n1 n0 +reduceNode (TCross1Node lvl0 namep _ r0) (BoxNode lvl1 _ r1) = commute0 + (TCross1Node (if lvl0 < lvl1 then lvl0 else succ lvl0) namep) + (BoxNode lvl1) + r0 r1 +reduceNode n0@BoxNode {} n1@TCross1Node {} = reduceNode n1 n0 +reduceNode (TCross2Node lvl0 namep _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (TCross2Node (if lvl0 < lvl1 then lvl0 else succ lvl0) namep) (BoxNode lvl1) r0 r1 r2 -reduceNode n0@BoxNode {} n1@TCrossNode {} = reduceNode n1 n0 -reduceNode (TEntryNode name opp _ r0) (BoxNode lvl _ r1) - = commute0 (TEntryNode name opp) (BoxNode lvl) r0 r1 +reduceNode n0@BoxNode {} n1@TCross2Node {} = reduceNode n1 n0 +reduceNode (TEntryNode _ r0 r1) (BoxNode lvl _ r2) + = commute1 TEntryNode (BoxNode lvl) r0 r1 r2 reduceNode n0@BoxNode {} n1@TEntryNode {} = reduceNode n1 n0 reduceNode (TSplitNode _ r0 r1) (BoxNode lvl _ r2) = commute1 TSplitNode (BoxNode lvl) r0 r1 r2 @@ -1031,14 +1295,19 @@ reduceNode (TMatchNode lvl0 _ r0 r1 r2) (BoxNode lvl1 _ r3) = commute2b (BoxNode lvl1) r0 r1 r2 r3 reduceNode n0@BoxNode {} n1@TMatchNode {} = reduceNode n1 n0 -reduceNode (PArgumentNode _ r0 r1) (BoxNode lvl _ r2) - = commute1 PArgumentNode (BoxNode lvl) r0 r1 r2 +reduceNode (PArgumentNode t _ r0 r1) (BoxNode lvl _ r2) + = commute1 (PArgumentNode t) (BoxNode lvl) r0 r1 r2 reduceNode n0@BoxNode {} n1@PArgumentNode {} = reduceNode n1 n0 reduceNode (PReduceNode _ r0) (BoxNode _ _ r1) = do rn2 <- newNode $ PReduceNode () () linkNodes r0 $ Ref rn2 1 linkNodes r1 $ Ref rn2 0 reduceNode n0@BoxNode {} n1@PReduceNode {} = reduceNode n1 n0 +reduceNode (DupIONode lvl0 _ r0 r1) (BoxNode lvl1 _ r2) = commute1 + (DupIONode $ if lvl0 < lvl1 then lvl0 else succ lvl0) + (BoxNode lvl1) + r0 r1 r2 +reduceNode n0@BoxNode {} n1@DupIONode {} = reduceNode n1 n0 reduceNode n0 n1 = error . show $ "unexpected node pairing" <> line <> pretty n0 <> line <> pretty n1 {-# INLINABLE reduceNode #-} @@ -1179,19 +1448,43 @@ dedupIO :: HasRewriter sig m => Level -> Ref -> Ref -> Ref -> m () dedupIO lvl r0 r1 r2 = do name <- newName namep <- newName - rn3 <- newNode $ TEntryNode name (B.Constant B.B1) () () - rn4 <- newNode $ TEntryNode name (B.Constant B.B0) () () - rn5 <- newNode $ TBuildNode lvl BuildIO namep () () () () + let opp = B.Reference (B.IntType 1) namep + mk = B.Block mempty . B.TailCall name . B.Constant + rn3 <- newNode $ TEntryNode () () () + rn4 <- newNode $ TEntryNode () () () + rn5 <- newNode $ TBuild2Node lvl BuildIO opp () () () () rn6 <- newNode $ AccumIONode mempty () () linkNodes (Ref rn3 1) (Ref rn5 1) linkNodes (Ref rn4 1) (Ref rn5 2) linkNodes (Ref rn5 3) (Ref rn6 0) + propagate1 (Ref rn3 2) $ IONode $ B.BlockList (mk B.B1) mempty + propagate1 (Ref rn4 2) $ IONode $ B.BlockList (mk B.B0) mempty propagate1 (Ref rn6 1) $ PrivateRootNode name namep linkNodes r0 $ Ref rn3 0 linkNodes r1 $ Ref rn4 0 linkNodes r2 $ Ref rn5 0 {-# INLINABLE dedupIO #-} +dedupIO' :: HasRewriter sig m => Level -> Ref -> Ref -> Ref -> m () +dedupIO' lvl r0 r1 r2 = do + name <- newName + namep <- newName + let opp = B.Reference (B.IntType 1) namep + rn2 <- newNode $ TEntryNode () () () + rn3 <- newNode $ TBuild1Node lvl BuildIO opp () () () + rn4 <- newNode $ AccumIONode mempty () () + rn5 <- newNode $ TailCallNode name () () + rn6 <- newNode $ PReduceNode () () + linkNodes (Ref rn2 1) (Ref rn3 1) + linkNodes (Ref rn2 2) (Ref rn5 1) + linkNodes (Ref rn3 2) (Ref rn4 0) + linkNodes (Ref rn5 0) (Ref rn6 1) + propagate1 (Ref rn4 1) $ PrivateRootNode name namep + linkNodes r0 $ Ref rn6 0 + linkNodes r1 $ Ref rn2 0 + linkNodes r2 $ Ref rn3 0 +{-# INLINABLE dedupIO' #-} + reassocPure :: HasRewriter sig m => Ref -> Ref -> m () reassocPure r0 r1 = do rn2 <- newNode $ LamNode () () () @@ -1225,12 +1518,13 @@ reassocPure r0 r1 = do {-# INLINABLE reassocPure #-} -- | @r0 = \a -> IOPure (\b -> Bind1C r1 (\c -> Bind0C (a c) b))@ -reassocCont :: HasRewriter sig m => Ref -> Ref -> m () -reassocCont r0 r1 = do +reassocCont :: HasRewriter sig m => B.Type -> Ref -> Ref -> m () +reassocCont t r0 r1 = do + name <- newName rn2 <- newNode $ LamNode () () () rn3 <- newNode $ IOPureNode () () rn4 <- newNode $ LamNode () () () - rn5 <- newNode $ Bind1CNode () () () + rn5 <- newNode $ Bind1CNode name () () () rn6 <- newNode $ BoxNode 0 () () rn7 <- newNode $ BoxNode 0 () () rn8 <- newNode $ LamNode () () () @@ -1239,20 +1533,23 @@ reassocCont r0 r1 = do rn11 <- newNode $ BoxNode 0 () () rn12 <- newNode $ BoxNode 0 () () rn13 <- newNode $ BoxNode 0 () () + rn14 <- newNode $ AppNode () () () linkNodes (Ref rn2 1) (Ref rn11 0) linkNodes (Ref rn2 2) (Ref rn3 0) linkNodes (Ref rn3 1) (Ref rn4 0) linkNodes (Ref rn4 1) (Ref rn13 0) linkNodes (Ref rn4 2) (Ref rn5 0) linkNodes (Ref rn5 1) (Ref rn7 1) - linkNodes (Ref rn5 2) (Ref rn8 0) + linkNodes (Ref rn5 2) (Ref rn14 2) linkNodes (Ref rn6 1) (Ref rn7 0) + linkNodes (Ref rn8 0) (Ref rn14 0) linkNodes (Ref rn8 1) (Ref rn10 1) linkNodes (Ref rn8 2) (Ref rn9 2) linkNodes (Ref rn9 0) (Ref rn10 2) linkNodes (Ref rn9 1) (Ref rn13 1) linkNodes (Ref rn10 0) (Ref rn12 1) linkNodes (Ref rn11 1) (Ref rn12 0) + propagate1 (Ref rn14 1) $ OperandNode $ B.Reference t name linkNodes r0 $ Ref rn2 0 linkNodes r1 $ Ref rn6 0 {-# INLINABLE reassocCont #-} diff --git a/test/Golden.hs b/test/Golden.hs index acd3133..fb0e371 100644 --- a/test/Golden.hs +++ b/test/Golden.hs @@ -139,9 +139,9 @@ passes = LLVM.Pass.CuratedPassSetSpec , LLVM.Pass.sizeLevel = Nothing , LLVM.Pass.unitAtATime = Nothing , LLVM.Pass.simplifyLibCalls = Nothing - , LLVM.Pass.loopVectorize = Nothing - , LLVM.Pass.superwordLevelParallelismVectorize = Nothing - , LLVM.Pass.useInlinerWithThreshold = Nothing + , LLVM.Pass.loopVectorize = Just True + , LLVM.Pass.superwordLevelParallelismVectorize = Just True + , LLVM.Pass.useInlinerWithThreshold = Just 65536 , LLVM.Pass.dataLayout = Nothing , LLVM.Pass.targetLibraryInfo = Nothing , LLVM.Pass.targetMachine = Nothing @@ -267,13 +267,14 @@ data NodeHead | ExternalRootHead | PrivateRootHead | AccumIOHead | AccumNBHead | OperandHead | OperandAHead | OperandPHead | IOHead | IOAHead | IOPHead | IOPureHead | IOContHead - | ReturnCHead | ReturnFHead + | ReturnCHead | ReturnFHead | TailCallHead | Bind0BHead | Bind0CHead | Bind0FHead | Bind1CHead | Bind1FHead | Branch0CHead | Branch0FHead | LabelHead | NamedBlockHead | Merge0Head | Merge1Head - | TBuildHead | TCrossHead | TEntryHead | TSplitHead - | TCloseHead | TLeaveHead | TMatchHead + | TBuild1Head | TBuild2Head | TCross1Head | TCross2Head + | TEntryHead | TSplitHead | TCloseHead | TLeaveHead | TMatchHead | PArgumentHead | PReduceHead + | DupIOHead deriving stock (Eq, Ord) instance Pretty NodeHead where @@ -296,6 +297,7 @@ instance Pretty NodeHead where pretty IOContHead = "IOCont" pretty ReturnCHead = "ReturnC" pretty ReturnFHead = "ReturnF" + pretty TailCallHead = "TailCall" pretty Bind0BHead = "Bind0B" pretty Bind0CHead = "Bind0C" pretty Bind0FHead = "Bind0F" @@ -307,8 +309,10 @@ instance Pretty NodeHead where pretty NamedBlockHead = "NamedBlock" pretty Merge0Head = "Merge0" pretty Merge1Head = "Merge1" - pretty TBuildHead = "TBuild" - pretty TCrossHead = "TCross" + pretty TBuild1Head = "TBuild1" + pretty TBuild2Head = "TBuild2" + pretty TCross1Head = "TCross1" + pretty TCross2Head = "TCross2" pretty TEntryHead = "TEntry" pretty TSplitHead = "TSplit" pretty TCloseHead = "TClose" @@ -316,6 +320,7 @@ instance Pretty NodeHead where pretty TMatchHead = "TMatch" pretty PArgumentHead = "PArgument" pretty PReduceHead = "PReduce" + pretty DupIOHead = "DupIO" nodeHead :: INetF a -> NodeHead nodeHead x = case x of @@ -338,6 +343,7 @@ nodeHead x = case x of IOContNode {} -> IOContHead ReturnCNode {} -> ReturnCHead ReturnFNode {} -> ReturnFHead + TailCallNode {} -> TailCallHead Bind0BNode {} -> Bind0BHead Bind0CNode {} -> Bind0CHead Bind0FNode {} -> Bind0FHead @@ -349,8 +355,10 @@ nodeHead x = case x of NamedBlockNode {} -> NamedBlockHead Merge0Node {} -> Merge0Head Merge1Node {} -> Merge1Head - TBuildNode {} -> TBuildHead - TCrossNode {} -> TCrossHead + TBuild1Node {} -> TBuild1Head + TBuild2Node {} -> TBuild2Head + TCross1Node {} -> TCross1Head + TCross2Node {} -> TCross2Head TEntryNode {} -> TEntryHead TSplitNode {} -> TSplitHead TCloseNode {} -> TCloseHead @@ -358,6 +366,7 @@ nodeHead x = case x of TMatchNode {} -> TMatchHead PArgumentNode {} -> PArgumentHead PReduceNode {} -> PReduceHead + DupIONode {} -> DupIOHead hPutDoc :: Handle -> Doc ann -> IO () hPutDoc h doc = renderIO h $ layoutPretty opts doc diff --git a/test/Golden/Arithmetic.opt.ll b/test/Golden/Arithmetic.opt.ll index 66ffd0f..2f10210 100644 --- a/test/Golden/Arithmetic.opt.ll +++ b/test/Golden/Arithmetic.opt.ll @@ -3,12 +3,11 @@ source_filename = "test/Golden/Arithmetic.elem" ; Function Attrs: norecurse nounwind readnone define i1 @expsign(i2, i2) local_unnamed_addr #0 { -__elem_0.exit: - %2 = and i2 %0, 1 - %3 = icmp ne i2 %2, 0 - %4 = icmp eq i2 %1, 0 - %spec.select = or i1 %4, %3 - ret i1 %spec.select + %3 = and i2 %0, 1 + %4 = icmp ne i2 %3, 0 + %5 = icmp eq i2 %1, 0 + %6 = or i1 %5, %4 + ret i1 %6 } attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/BitOrder.opt.ll b/test/Golden/BitOrder.opt.ll index 235eefe..0fc962b 100644 --- a/test/Golden/BitOrder.opt.ll +++ b/test/Golden/BitOrder.opt.ll @@ -3,9 +3,8 @@ source_filename = "test/Golden/BitOrder.elem" ; Function Attrs: norecurse nounwind readnone define i2 @main(i2) local_unnamed_addr #0 { -__elem_0.exit: - %1 = xor i2 %0, 1 - ret i2 %1 + %2 = xor i2 %0, 1 + ret i2 %2 } attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/BranchIO.opt.ll b/test/Golden/BranchIO.opt.ll index 8eac301..ddc5256 100644 --- a/test/Golden/BranchIO.opt.ll +++ b/test/Golden/BranchIO.opt.ll @@ -10,9 +10,12 @@ define void @main(i1) local_unnamed_addr { 2: ; preds = %1 tail call void @t() - ret void + br label %__elem_0.exit 3: ; preds = %1 tail call void @f() + br label %__elem_0.exit + +__elem_0.exit: ; preds = %3, %2 ret void } diff --git a/test/Golden/CallOrder.opt.ll b/test/Golden/CallOrder.opt.ll index 8164b11..9b072ab 100644 --- a/test/Golden/CallOrder.opt.ll +++ b/test/Golden/CallOrder.opt.ll @@ -4,61 +4,6 @@ source_filename = "test/Golden/CallOrder.elem" declare void @dothing(i2, i1) local_unnamed_addr define void @main(i2, i1) local_unnamed_addr { - %3 = icmp sgt i2 %0, -1 - %4 = and i2 %0, 1 - %5 = icmp eq i2 %4, 0 - br i1 %3, label %11, label %6 - -6: ; preds = %2 - br i1 %5, label %9, label %7 - -7: ; preds = %6 - br i1 %1, label %8, label %codeRepl.i.i - -8: ; preds = %7 - tail call void @dothing(i2 -1, i1 true) - br label %__elem_0.exit - -codeRepl.i.i: ; preds = %7 - tail call void @dothing(i2 -1, i1 false) - br label %__elem_0.exit - -9: ; preds = %6 - br i1 %1, label %10, label %codeRepl.i1.i - -10: ; preds = %9 - tail call void @dothing(i2 -2, i1 true) - br label %__elem_0.exit - -codeRepl.i1.i: ; preds = %9 - tail call void @dothing(i2 -2, i1 false) - br label %__elem_0.exit - -__elem_0.exit: ; preds = %15, %codeRepl.i1.i3, %13, %codeRepl.i.i1, %10, %codeRepl.i1.i, %8, %codeRepl.i.i + tail call void @dothing(i2 %0, i1 %1) ret void - -11: ; preds = %2 - br i1 %5, label %14, label %12 - -12: ; preds = %11 - br i1 %1, label %13, label %codeRepl.i.i1 - -13: ; preds = %12 - tail call void @dothing(i2 1, i1 true) - br label %__elem_0.exit - -codeRepl.i.i1: ; preds = %12 - tail call void @dothing(i2 1, i1 false) - br label %__elem_0.exit - -14: ; preds = %11 - br i1 %1, label %15, label %codeRepl.i1.i3 - -15: ; preds = %14 - tail call void @dothing(i2 0, i1 true) - br label %__elem_0.exit - -codeRepl.i1.i3: ; preds = %14 - tail call void @dothing(i2 0, i1 false) - br label %__elem_0.exit } diff --git a/test/Golden/CataDynamic.opt.ll b/test/Golden/CataDynamic.opt.ll index 669ab8f..3fbb1bc 100644 --- a/test/Golden/CataDynamic.opt.ll +++ b/test/Golden/CataDynamic.opt.ll @@ -6,13 +6,13 @@ declare void @dothing() local_unnamed_addr define void @main(i1) local_unnamed_addr { tail call void @dothing() tail call void @dothing() - br i1 %0, label %2, label %3 + br i1 %0, label %__elem_0.exit, label %2 2: ; preds = %1 - ret void - -3: ; preds = %1 tail call void @dothing() tail call void @dothing() + br label %__elem_0.exit + +__elem_0.exit: ; preds = %1, %2 ret void } diff --git a/test/Golden/CataStaticAccum.opt.ll b/test/Golden/CataStaticAccum.opt.ll index fa6d66c..305e6cd 100644 --- a/test/Golden/CataStaticAccum.opt.ll +++ b/test/Golden/CataStaticAccum.opt.ll @@ -7,14 +7,7 @@ define i1 @main() local_unnamed_addr { %1 = tail call i1 @dothing() %2 = tail call i1 @dothing() %3 = tail call i1 @dothing() - %not.1 = xor i1 %3, true - br i1 %1, label %4, label %__elem_2.exit - -4: ; preds = %0 - %spec.select = select i1 %2, i1 %3, i1 %not.1 - ret i1 %spec.select - -__elem_2.exit: ; preds = %0 - %spec.select2 = select i1 %2, i1 %not.1, i1 %3 - ret i1 %spec.select2 + %.v.i.i.i.i.i.i.i = xor i1 %1, %2 + %4 = xor i1 %.v.i.i.i.i.i.i.i, %3 + ret i1 %4 } diff --git a/test/Golden/EchoChar.opt.ll b/test/Golden/EchoChar.opt.ll index 6629f42..ce1292d 100644 --- a/test/Golden/EchoChar.opt.ll +++ b/test/Golden/EchoChar.opt.ll @@ -8,859 +8,8 @@ declare i8 @getchar() local_unnamed_addr #0 define void @main() local_unnamed_addr { %1 = tail call i8 @getchar() - %2 = icmp sgt i8 %1, -1 - %3 = and i8 %1, 64 - %4 = icmp eq i8 %3, 0 - %5 = and i8 %1, 32 - %6 = icmp eq i8 %5, 0 - %7 = and i8 %1, 16 - %8 = icmp eq i8 %7, 0 - br i1 %2, label %231, label %9 - -9: ; preds = %0 - br i1 %4, label %122, label %codeRepl.i - -codeRepl.i: ; preds = %9 - br i1 %6, label %67, label %10 - -10: ; preds = %codeRepl.i - br i1 %8, label %39, label %codeRepl.i.i - -codeRepl.i.i: ; preds = %10 - %11 = and i8 %1, 8 - %12 = icmp eq i8 %11, 0 - %13 = and i8 %1, 4 - %14 = icmp eq i8 %13, 0 - %15 = and i8 %1, 2 - %16 = icmp eq i8 %15, 0 - %17 = and i8 %1, 1 - %18 = trunc i8 %17 to i3 - %19 = icmp eq i8 %17, 0 - %..i7.i = select i1 %19, i3 2, i3 3 - %.sink.i8.i = select i1 %16, i3 %18, i3 %..i7.i - br i1 %12, label %27, label %20 - -20: ; preds = %codeRepl.i.i - %21 = zext i3 %.sink.i8.i to i4 - br i1 %14, label %24, label %codeRepl.i.i12 - -codeRepl.i.i12: ; preds = %20 - %22 = or i4 %21, -4 - %23 = zext i4 %22 to i5 - br label %__elem_3.exit - -24: ; preds = %20 - %25 = or i4 %21, -8 - %26 = zext i4 %25 to i5 - br label %__elem_3.exit - -27: ; preds = %codeRepl.i.i - br i1 %14, label %30, label %codeRepl.i1.i13 - -codeRepl.i1.i13: ; preds = %27 - %28 = or i3 %.sink.i8.i, -4 - %29 = zext i3 %28 to i5 - br label %__elem_3.exit - -30: ; preds = %27 - %31 = zext i3 %.sink.i8.i to i5 - br label %__elem_3.exit - -__elem_3.exit: ; preds = %codeRepl.i.i12, %24, %codeRepl.i1.i13, %30 - %.sink17.i = phi i5 [ %29, %codeRepl.i1.i13 ], [ %31, %30 ], [ %26, %24 ], [ %23, %codeRepl.i.i12 ] - %32 = or i5 %.sink17.i, -16 - %33 = zext i5 %32 to i6 - %34 = or i6 -32, %33 - %35 = zext i6 %34 to i7 - %36 = or i7 -64, %35 - %37 = zext i7 %36 to i8 - %38 = or i8 -128, %37 - tail call void @putchar(i8 %38) - br label %__elem_0.4.exit - -39: ; preds = %10 - %40 = and i8 %1, 8 - %41 = icmp eq i8 %40, 0 - %42 = and i8 %1, 4 - %43 = icmp eq i8 %42, 0 - %44 = and i8 %1, 2 - %45 = icmp eq i8 %44, 0 - %46 = and i8 %1, 1 - %47 = trunc i8 %46 to i3 - %48 = icmp eq i8 %46, 0 - %..i7.i14 = select i1 %48, i3 2, i3 3 - %.sink.i8.i15 = select i1 %45, i3 %47, i3 %..i7.i14 - br i1 %41, label %56, label %49 - -49: ; preds = %39 - %50 = zext i3 %.sink.i8.i15 to i4 - br i1 %43, label %53, label %codeRepl.i.i16 - -codeRepl.i.i16: ; preds = %49 - %51 = or i4 %50, -4 - %52 = zext i4 %51 to i5 - br label %__elem_3.exit19 - -53: ; preds = %49 - %54 = or i4 %50, -8 - %55 = zext i4 %54 to i5 - br label %__elem_3.exit19 - -56: ; preds = %39 - br i1 %43, label %59, label %codeRepl.i1.i18 - -codeRepl.i1.i18: ; preds = %56 - %57 = or i3 %.sink.i8.i15, -4 - %58 = zext i3 %57 to i5 - br label %__elem_3.exit19 - -59: ; preds = %56 - %60 = zext i3 %.sink.i8.i15 to i5 - br label %__elem_3.exit19 - -__elem_3.exit19: ; preds = %codeRepl.i.i16, %53, %codeRepl.i1.i18, %59 - %.sink17.i17 = phi i5 [ %58, %codeRepl.i1.i18 ], [ %60, %59 ], [ %55, %53 ], [ %52, %codeRepl.i.i16 ] - %61 = zext i5 %.sink17.i17 to i6 - %62 = or i6 -32, %61 - %63 = zext i6 %62 to i7 - %64 = or i7 -64, %63 - %65 = zext i7 %64 to i8 - %66 = or i8 -128, %65 - tail call void @putchar(i8 %66) - br label %__elem_0.4.exit - -67: ; preds = %codeRepl.i - br i1 %8, label %95, label %codeRepl.i1.i - -codeRepl.i1.i: ; preds = %67 - %68 = and i8 %1, 8 - %69 = icmp eq i8 %68, 0 - %70 = and i8 %1, 4 - %71 = icmp eq i8 %70, 0 - %72 = and i8 %1, 2 - %73 = icmp eq i8 %72, 0 - %74 = and i8 %1, 1 - %75 = trunc i8 %74 to i3 - %76 = icmp eq i8 %74, 0 - %..i7.i20 = select i1 %76, i3 2, i3 3 - %.sink.i8.i21 = select i1 %73, i3 %75, i3 %..i7.i20 - br i1 %69, label %84, label %77 - -77: ; preds = %codeRepl.i1.i - %78 = zext i3 %.sink.i8.i21 to i4 - br i1 %71, label %81, label %codeRepl.i.i22 - -codeRepl.i.i22: ; preds = %77 - %79 = or i4 %78, -4 - %80 = zext i4 %79 to i5 - br label %__elem_3.exit25 - -81: ; preds = %77 - %82 = or i4 %78, -8 - %83 = zext i4 %82 to i5 - br label %__elem_3.exit25 - -84: ; preds = %codeRepl.i1.i - br i1 %71, label %87, label %codeRepl.i1.i24 - -codeRepl.i1.i24: ; preds = %84 - %85 = or i3 %.sink.i8.i21, -4 - %86 = zext i3 %85 to i5 - br label %__elem_3.exit25 - -87: ; preds = %84 - %88 = zext i3 %.sink.i8.i21 to i5 - br label %__elem_3.exit25 - -__elem_3.exit25: ; preds = %codeRepl.i.i22, %81, %codeRepl.i1.i24, %87 - %.sink17.i23 = phi i5 [ %86, %codeRepl.i1.i24 ], [ %88, %87 ], [ %83, %81 ], [ %80, %codeRepl.i.i22 ] - %89 = or i5 %.sink17.i23, -16 - %90 = zext i5 %89 to i6 - %91 = zext i6 %90 to i7 - %92 = or i7 -64, %91 - %93 = zext i7 %92 to i8 - %94 = or i8 -128, %93 - tail call void @putchar(i8 %94) - br label %__elem_0.4.exit - -95: ; preds = %67 - %96 = and i8 %1, 8 - %97 = icmp eq i8 %96, 0 - %98 = and i8 %1, 4 - %99 = icmp eq i8 %98, 0 - %100 = and i8 %1, 2 - %101 = icmp eq i8 %100, 0 - %102 = and i8 %1, 1 - %103 = trunc i8 %102 to i3 - %104 = icmp eq i8 %102, 0 - %..i7.i26 = select i1 %104, i3 2, i3 3 - %.sink.i8.i27 = select i1 %101, i3 %103, i3 %..i7.i26 - br i1 %97, label %112, label %105 - -105: ; preds = %95 - %106 = zext i3 %.sink.i8.i27 to i4 - br i1 %99, label %109, label %codeRepl.i.i28 - -codeRepl.i.i28: ; preds = %105 - %107 = or i4 %106, -4 - %108 = zext i4 %107 to i5 - br label %__elem_3.exit31 - -109: ; preds = %105 - %110 = or i4 %106, -8 - %111 = zext i4 %110 to i5 - br label %__elem_3.exit31 - -112: ; preds = %95 - br i1 %99, label %115, label %codeRepl.i1.i30 - -codeRepl.i1.i30: ; preds = %112 - %113 = or i3 %.sink.i8.i27, -4 - %114 = zext i3 %113 to i5 - br label %__elem_3.exit31 - -115: ; preds = %112 - %116 = zext i3 %.sink.i8.i27 to i5 - br label %__elem_3.exit31 - -__elem_3.exit31: ; preds = %codeRepl.i.i28, %109, %codeRepl.i1.i30, %115 - %.sink17.i29 = phi i5 [ %114, %codeRepl.i1.i30 ], [ %116, %115 ], [ %111, %109 ], [ %108, %codeRepl.i.i28 ] - %117 = zext i5 %.sink17.i29 to i6 - %118 = zext i6 %117 to i7 - %119 = or i7 -64, %118 - %120 = zext i7 %119 to i8 - %121 = or i8 -128, %120 - tail call void @putchar(i8 %121) - br label %__elem_0.4.exit - -122: ; preds = %9 - br i1 %6, label %178, label %123 - -123: ; preds = %122 - br i1 %8, label %151, label %codeRepl.i.i3 - -codeRepl.i.i3: ; preds = %123 - %124 = and i8 %1, 8 - %125 = icmp eq i8 %124, 0 - %126 = and i8 %1, 4 - %127 = icmp eq i8 %126, 0 - %128 = and i8 %1, 2 - %129 = icmp eq i8 %128, 0 - %130 = and i8 %1, 1 - %131 = trunc i8 %130 to i3 - %132 = icmp eq i8 %130, 0 - %..i7.i32 = select i1 %132, i3 2, i3 3 - %.sink.i8.i33 = select i1 %129, i3 %131, i3 %..i7.i32 - br i1 %125, label %140, label %133 - -133: ; preds = %codeRepl.i.i3 - %134 = zext i3 %.sink.i8.i33 to i4 - br i1 %127, label %137, label %codeRepl.i.i34 - -codeRepl.i.i34: ; preds = %133 - %135 = or i4 %134, -4 - %136 = zext i4 %135 to i5 - br label %__elem_3.exit37 - -137: ; preds = %133 - %138 = or i4 %134, -8 - %139 = zext i4 %138 to i5 - br label %__elem_3.exit37 - -140: ; preds = %codeRepl.i.i3 - br i1 %127, label %143, label %codeRepl.i1.i36 - -codeRepl.i1.i36: ; preds = %140 - %141 = or i3 %.sink.i8.i33, -4 - %142 = zext i3 %141 to i5 - br label %__elem_3.exit37 - -143: ; preds = %140 - %144 = zext i3 %.sink.i8.i33 to i5 - br label %__elem_3.exit37 - -__elem_3.exit37: ; preds = %codeRepl.i.i34, %137, %codeRepl.i1.i36, %143 - %.sink17.i35 = phi i5 [ %142, %codeRepl.i1.i36 ], [ %144, %143 ], [ %139, %137 ], [ %136, %codeRepl.i.i34 ] - %145 = or i5 %.sink17.i35, -16 - %146 = zext i5 %145 to i6 - %147 = or i6 -32, %146 - %148 = zext i6 %147 to i7 - %149 = zext i7 %148 to i8 - %150 = or i8 -128, %149 - tail call void @putchar(i8 %150) - br label %__elem_0.4.exit - -151: ; preds = %123 - %152 = and i8 %1, 8 - %153 = icmp eq i8 %152, 0 - %154 = and i8 %1, 4 - %155 = icmp eq i8 %154, 0 - %156 = and i8 %1, 2 - %157 = icmp eq i8 %156, 0 - %158 = and i8 %1, 1 - %159 = trunc i8 %158 to i3 - %160 = icmp eq i8 %158, 0 - %..i7.i38 = select i1 %160, i3 2, i3 3 - %.sink.i8.i39 = select i1 %157, i3 %159, i3 %..i7.i38 - br i1 %153, label %168, label %161 - -161: ; preds = %151 - %162 = zext i3 %.sink.i8.i39 to i4 - br i1 %155, label %165, label %codeRepl.i.i40 - -codeRepl.i.i40: ; preds = %161 - %163 = or i4 %162, -4 - %164 = zext i4 %163 to i5 - br label %__elem_3.exit43 - -165: ; preds = %161 - %166 = or i4 %162, -8 - %167 = zext i4 %166 to i5 - br label %__elem_3.exit43 - -168: ; preds = %151 - br i1 %155, label %171, label %codeRepl.i1.i42 - -codeRepl.i1.i42: ; preds = %168 - %169 = or i3 %.sink.i8.i39, -4 - %170 = zext i3 %169 to i5 - br label %__elem_3.exit43 - -171: ; preds = %168 - %172 = zext i3 %.sink.i8.i39 to i5 - br label %__elem_3.exit43 - -__elem_3.exit43: ; preds = %codeRepl.i.i40, %165, %codeRepl.i1.i42, %171 - %.sink17.i41 = phi i5 [ %170, %codeRepl.i1.i42 ], [ %172, %171 ], [ %167, %165 ], [ %164, %codeRepl.i.i40 ] - %173 = zext i5 %.sink17.i41 to i6 - %174 = or i6 -32, %173 - %175 = zext i6 %174 to i7 - %176 = zext i7 %175 to i8 - %177 = or i8 -128, %176 - tail call void @putchar(i8 %177) - br label %__elem_0.4.exit - -178: ; preds = %122 - br i1 %8, label %205, label %codeRepl.i1.i4 - -codeRepl.i1.i4: ; preds = %178 - %179 = and i8 %1, 8 - %180 = icmp eq i8 %179, 0 - %181 = and i8 %1, 4 - %182 = icmp eq i8 %181, 0 - %183 = and i8 %1, 2 - %184 = icmp eq i8 %183, 0 - %185 = and i8 %1, 1 - %186 = trunc i8 %185 to i3 - %187 = icmp eq i8 %185, 0 - %..i7.i44 = select i1 %187, i3 2, i3 3 - %.sink.i8.i45 = select i1 %184, i3 %186, i3 %..i7.i44 - br i1 %180, label %195, label %188 - -188: ; preds = %codeRepl.i1.i4 - %189 = zext i3 %.sink.i8.i45 to i4 - br i1 %182, label %192, label %codeRepl.i.i46 - -codeRepl.i.i46: ; preds = %188 - %190 = or i4 %189, -4 - %191 = zext i4 %190 to i5 - br label %__elem_3.exit49 - -192: ; preds = %188 - %193 = or i4 %189, -8 - %194 = zext i4 %193 to i5 - br label %__elem_3.exit49 - -195: ; preds = %codeRepl.i1.i4 - br i1 %182, label %198, label %codeRepl.i1.i48 - -codeRepl.i1.i48: ; preds = %195 - %196 = or i3 %.sink.i8.i45, -4 - %197 = zext i3 %196 to i5 - br label %__elem_3.exit49 - -198: ; preds = %195 - %199 = zext i3 %.sink.i8.i45 to i5 - br label %__elem_3.exit49 - -__elem_3.exit49: ; preds = %codeRepl.i.i46, %192, %codeRepl.i1.i48, %198 - %.sink17.i47 = phi i5 [ %197, %codeRepl.i1.i48 ], [ %199, %198 ], [ %194, %192 ], [ %191, %codeRepl.i.i46 ] - %200 = or i5 %.sink17.i47, -16 - %201 = zext i5 %200 to i6 - %202 = zext i6 %201 to i7 - %203 = zext i7 %202 to i8 - %204 = or i8 -128, %203 - tail call void @putchar(i8 %204) - br label %__elem_0.4.exit - -205: ; preds = %178 - %206 = and i8 %1, 8 - %207 = icmp eq i8 %206, 0 - %208 = and i8 %1, 4 - %209 = icmp eq i8 %208, 0 - %210 = and i8 %1, 2 - %211 = icmp eq i8 %210, 0 - %212 = and i8 %1, 1 - %213 = trunc i8 %212 to i3 - %214 = icmp eq i8 %212, 0 - %..i7.i50 = select i1 %214, i3 2, i3 3 - %.sink.i8.i51 = select i1 %211, i3 %213, i3 %..i7.i50 - br i1 %207, label %222, label %215 - -215: ; preds = %205 - %216 = zext i3 %.sink.i8.i51 to i4 - br i1 %209, label %219, label %codeRepl.i.i52 - -codeRepl.i.i52: ; preds = %215 - %217 = or i4 %216, -4 - %218 = zext i4 %217 to i5 - br label %__elem_3.exit55 - -219: ; preds = %215 - %220 = or i4 %216, -8 - %221 = zext i4 %220 to i5 - br label %__elem_3.exit55 - -222: ; preds = %205 - br i1 %209, label %225, label %codeRepl.i1.i54 - -codeRepl.i1.i54: ; preds = %222 - %223 = or i3 %.sink.i8.i51, -4 - %224 = zext i3 %223 to i5 - br label %__elem_3.exit55 - -225: ; preds = %222 - %226 = zext i3 %.sink.i8.i51 to i5 - br label %__elem_3.exit55 - -__elem_3.exit55: ; preds = %codeRepl.i.i52, %219, %codeRepl.i1.i54, %225 - %.sink17.i53 = phi i5 [ %224, %codeRepl.i1.i54 ], [ %226, %225 ], [ %221, %219 ], [ %218, %codeRepl.i.i52 ] - %227 = zext i5 %.sink17.i53 to i6 - %228 = zext i6 %227 to i7 - %229 = zext i7 %228 to i8 - %230 = or i8 -128, %229 - tail call void @putchar(i8 %230) - br label %__elem_0.4.exit - -__elem_0.4.exit: ; preds = %__elem_3.exit103, %__elem_3.exit97, %__elem_3.exit91, %__elem_3.exit85, %__elem_3.exit79, %__elem_3.exit73, %__elem_3.exit67, %__elem_3.exit61, %__elem_3.exit55, %__elem_3.exit49, %__elem_3.exit43, %__elem_3.exit37, %__elem_3.exit31, %__elem_3.exit25, %__elem_3.exit19, %__elem_3.exit + tail call void @putchar(i8 %1) ret void - -231: ; preds = %0 - br i1 %4, label %340, label %codeRepl.i1 - -codeRepl.i1: ; preds = %231 - br i1 %6, label %287, label %232 - -232: ; preds = %codeRepl.i1 - br i1 %8, label %260, label %codeRepl.i.i6 - -codeRepl.i.i6: ; preds = %232 - %233 = and i8 %1, 8 - %234 = icmp eq i8 %233, 0 - %235 = and i8 %1, 4 - %236 = icmp eq i8 %235, 0 - %237 = and i8 %1, 2 - %238 = icmp eq i8 %237, 0 - %239 = and i8 %1, 1 - %240 = trunc i8 %239 to i3 - %241 = icmp eq i8 %239, 0 - %..i7.i56 = select i1 %241, i3 2, i3 3 - %.sink.i8.i57 = select i1 %238, i3 %240, i3 %..i7.i56 - br i1 %234, label %249, label %242 - -242: ; preds = %codeRepl.i.i6 - %243 = zext i3 %.sink.i8.i57 to i4 - br i1 %236, label %246, label %codeRepl.i.i58 - -codeRepl.i.i58: ; preds = %242 - %244 = or i4 %243, -4 - %245 = zext i4 %244 to i5 - br label %__elem_3.exit61 - -246: ; preds = %242 - %247 = or i4 %243, -8 - %248 = zext i4 %247 to i5 - br label %__elem_3.exit61 - -249: ; preds = %codeRepl.i.i6 - br i1 %236, label %252, label %codeRepl.i1.i60 - -codeRepl.i1.i60: ; preds = %249 - %250 = or i3 %.sink.i8.i57, -4 - %251 = zext i3 %250 to i5 - br label %__elem_3.exit61 - -252: ; preds = %249 - %253 = zext i3 %.sink.i8.i57 to i5 - br label %__elem_3.exit61 - -__elem_3.exit61: ; preds = %codeRepl.i.i58, %246, %codeRepl.i1.i60, %252 - %.sink17.i59 = phi i5 [ %251, %codeRepl.i1.i60 ], [ %253, %252 ], [ %248, %246 ], [ %245, %codeRepl.i.i58 ] - %254 = or i5 %.sink17.i59, -16 - %255 = zext i5 %254 to i6 - %256 = or i6 -32, %255 - %257 = zext i6 %256 to i7 - %258 = or i7 -64, %257 - %259 = zext i7 %258 to i8 - tail call void @putchar(i8 %259) - br label %__elem_0.4.exit - -260: ; preds = %232 - %261 = and i8 %1, 8 - %262 = icmp eq i8 %261, 0 - %263 = and i8 %1, 4 - %264 = icmp eq i8 %263, 0 - %265 = and i8 %1, 2 - %266 = icmp eq i8 %265, 0 - %267 = and i8 %1, 1 - %268 = trunc i8 %267 to i3 - %269 = icmp eq i8 %267, 0 - %..i7.i62 = select i1 %269, i3 2, i3 3 - %.sink.i8.i63 = select i1 %266, i3 %268, i3 %..i7.i62 - br i1 %262, label %277, label %270 - -270: ; preds = %260 - %271 = zext i3 %.sink.i8.i63 to i4 - br i1 %264, label %274, label %codeRepl.i.i64 - -codeRepl.i.i64: ; preds = %270 - %272 = or i4 %271, -4 - %273 = zext i4 %272 to i5 - br label %__elem_3.exit67 - -274: ; preds = %270 - %275 = or i4 %271, -8 - %276 = zext i4 %275 to i5 - br label %__elem_3.exit67 - -277: ; preds = %260 - br i1 %264, label %280, label %codeRepl.i1.i66 - -codeRepl.i1.i66: ; preds = %277 - %278 = or i3 %.sink.i8.i63, -4 - %279 = zext i3 %278 to i5 - br label %__elem_3.exit67 - -280: ; preds = %277 - %281 = zext i3 %.sink.i8.i63 to i5 - br label %__elem_3.exit67 - -__elem_3.exit67: ; preds = %codeRepl.i.i64, %274, %codeRepl.i1.i66, %280 - %.sink17.i65 = phi i5 [ %279, %codeRepl.i1.i66 ], [ %281, %280 ], [ %276, %274 ], [ %273, %codeRepl.i.i64 ] - %282 = zext i5 %.sink17.i65 to i6 - %283 = or i6 -32, %282 - %284 = zext i6 %283 to i7 - %285 = or i7 -64, %284 - %286 = zext i7 %285 to i8 - tail call void @putchar(i8 %286) - br label %__elem_0.4.exit - -287: ; preds = %codeRepl.i1 - br i1 %8, label %314, label %codeRepl.i1.i7 - -codeRepl.i1.i7: ; preds = %287 - %288 = and i8 %1, 8 - %289 = icmp eq i8 %288, 0 - %290 = and i8 %1, 4 - %291 = icmp eq i8 %290, 0 - %292 = and i8 %1, 2 - %293 = icmp eq i8 %292, 0 - %294 = and i8 %1, 1 - %295 = trunc i8 %294 to i3 - %296 = icmp eq i8 %294, 0 - %..i7.i68 = select i1 %296, i3 2, i3 3 - %.sink.i8.i69 = select i1 %293, i3 %295, i3 %..i7.i68 - br i1 %289, label %304, label %297 - -297: ; preds = %codeRepl.i1.i7 - %298 = zext i3 %.sink.i8.i69 to i4 - br i1 %291, label %301, label %codeRepl.i.i70 - -codeRepl.i.i70: ; preds = %297 - %299 = or i4 %298, -4 - %300 = zext i4 %299 to i5 - br label %__elem_3.exit73 - -301: ; preds = %297 - %302 = or i4 %298, -8 - %303 = zext i4 %302 to i5 - br label %__elem_3.exit73 - -304: ; preds = %codeRepl.i1.i7 - br i1 %291, label %307, label %codeRepl.i1.i72 - -codeRepl.i1.i72: ; preds = %304 - %305 = or i3 %.sink.i8.i69, -4 - %306 = zext i3 %305 to i5 - br label %__elem_3.exit73 - -307: ; preds = %304 - %308 = zext i3 %.sink.i8.i69 to i5 - br label %__elem_3.exit73 - -__elem_3.exit73: ; preds = %codeRepl.i.i70, %301, %codeRepl.i1.i72, %307 - %.sink17.i71 = phi i5 [ %306, %codeRepl.i1.i72 ], [ %308, %307 ], [ %303, %301 ], [ %300, %codeRepl.i.i70 ] - %309 = or i5 %.sink17.i71, -16 - %310 = zext i5 %309 to i6 - %311 = zext i6 %310 to i7 - %312 = or i7 -64, %311 - %313 = zext i7 %312 to i8 - tail call void @putchar(i8 %313) - br label %__elem_0.4.exit - -314: ; preds = %287 - %315 = and i8 %1, 8 - %316 = icmp eq i8 %315, 0 - %317 = and i8 %1, 4 - %318 = icmp eq i8 %317, 0 - %319 = and i8 %1, 2 - %320 = icmp eq i8 %319, 0 - %321 = and i8 %1, 1 - %322 = trunc i8 %321 to i3 - %323 = icmp eq i8 %321, 0 - %..i7.i74 = select i1 %323, i3 2, i3 3 - %.sink.i8.i75 = select i1 %320, i3 %322, i3 %..i7.i74 - br i1 %316, label %331, label %324 - -324: ; preds = %314 - %325 = zext i3 %.sink.i8.i75 to i4 - br i1 %318, label %328, label %codeRepl.i.i76 - -codeRepl.i.i76: ; preds = %324 - %326 = or i4 %325, -4 - %327 = zext i4 %326 to i5 - br label %__elem_3.exit79 - -328: ; preds = %324 - %329 = or i4 %325, -8 - %330 = zext i4 %329 to i5 - br label %__elem_3.exit79 - -331: ; preds = %314 - br i1 %318, label %334, label %codeRepl.i1.i78 - -codeRepl.i1.i78: ; preds = %331 - %332 = or i3 %.sink.i8.i75, -4 - %333 = zext i3 %332 to i5 - br label %__elem_3.exit79 - -334: ; preds = %331 - %335 = zext i3 %.sink.i8.i75 to i5 - br label %__elem_3.exit79 - -__elem_3.exit79: ; preds = %codeRepl.i.i76, %328, %codeRepl.i1.i78, %334 - %.sink17.i77 = phi i5 [ %333, %codeRepl.i1.i78 ], [ %335, %334 ], [ %330, %328 ], [ %327, %codeRepl.i.i76 ] - %336 = zext i5 %.sink17.i77 to i6 - %337 = zext i6 %336 to i7 - %338 = or i7 -64, %337 - %339 = zext i7 %338 to i8 - tail call void @putchar(i8 %339) - br label %__elem_0.4.exit - -340: ; preds = %231 - br i1 %6, label %394, label %341 - -341: ; preds = %340 - br i1 %8, label %368, label %codeRepl.i.i9 - -codeRepl.i.i9: ; preds = %341 - %342 = and i8 %1, 8 - %343 = icmp eq i8 %342, 0 - %344 = and i8 %1, 4 - %345 = icmp eq i8 %344, 0 - %346 = and i8 %1, 2 - %347 = icmp eq i8 %346, 0 - %348 = and i8 %1, 1 - %349 = trunc i8 %348 to i3 - %350 = icmp eq i8 %348, 0 - %..i7.i80 = select i1 %350, i3 2, i3 3 - %.sink.i8.i81 = select i1 %347, i3 %349, i3 %..i7.i80 - br i1 %343, label %358, label %351 - -351: ; preds = %codeRepl.i.i9 - %352 = zext i3 %.sink.i8.i81 to i4 - br i1 %345, label %355, label %codeRepl.i.i82 - -codeRepl.i.i82: ; preds = %351 - %353 = or i4 %352, -4 - %354 = zext i4 %353 to i5 - br label %__elem_3.exit85 - -355: ; preds = %351 - %356 = or i4 %352, -8 - %357 = zext i4 %356 to i5 - br label %__elem_3.exit85 - -358: ; preds = %codeRepl.i.i9 - br i1 %345, label %361, label %codeRepl.i1.i84 - -codeRepl.i1.i84: ; preds = %358 - %359 = or i3 %.sink.i8.i81, -4 - %360 = zext i3 %359 to i5 - br label %__elem_3.exit85 - -361: ; preds = %358 - %362 = zext i3 %.sink.i8.i81 to i5 - br label %__elem_3.exit85 - -__elem_3.exit85: ; preds = %codeRepl.i.i82, %355, %codeRepl.i1.i84, %361 - %.sink17.i83 = phi i5 [ %360, %codeRepl.i1.i84 ], [ %362, %361 ], [ %357, %355 ], [ %354, %codeRepl.i.i82 ] - %363 = or i5 %.sink17.i83, -16 - %364 = zext i5 %363 to i6 - %365 = or i6 -32, %364 - %366 = zext i6 %365 to i7 - %367 = zext i7 %366 to i8 - tail call void @putchar(i8 %367) - br label %__elem_0.4.exit - -368: ; preds = %341 - %369 = and i8 %1, 8 - %370 = icmp eq i8 %369, 0 - %371 = and i8 %1, 4 - %372 = icmp eq i8 %371, 0 - %373 = and i8 %1, 2 - %374 = icmp eq i8 %373, 0 - %375 = and i8 %1, 1 - %376 = trunc i8 %375 to i3 - %377 = icmp eq i8 %375, 0 - %..i7.i86 = select i1 %377, i3 2, i3 3 - %.sink.i8.i87 = select i1 %374, i3 %376, i3 %..i7.i86 - br i1 %370, label %385, label %378 - -378: ; preds = %368 - %379 = zext i3 %.sink.i8.i87 to i4 - br i1 %372, label %382, label %codeRepl.i.i88 - -codeRepl.i.i88: ; preds = %378 - %380 = or i4 %379, -4 - %381 = zext i4 %380 to i5 - br label %__elem_3.exit91 - -382: ; preds = %378 - %383 = or i4 %379, -8 - %384 = zext i4 %383 to i5 - br label %__elem_3.exit91 - -385: ; preds = %368 - br i1 %372, label %388, label %codeRepl.i1.i90 - -codeRepl.i1.i90: ; preds = %385 - %386 = or i3 %.sink.i8.i87, -4 - %387 = zext i3 %386 to i5 - br label %__elem_3.exit91 - -388: ; preds = %385 - %389 = zext i3 %.sink.i8.i87 to i5 - br label %__elem_3.exit91 - -__elem_3.exit91: ; preds = %codeRepl.i.i88, %382, %codeRepl.i1.i90, %388 - %.sink17.i89 = phi i5 [ %387, %codeRepl.i1.i90 ], [ %389, %388 ], [ %384, %382 ], [ %381, %codeRepl.i.i88 ] - %390 = zext i5 %.sink17.i89 to i6 - %391 = or i6 -32, %390 - %392 = zext i6 %391 to i7 - %393 = zext i7 %392 to i8 - tail call void @putchar(i8 %393) - br label %__elem_0.4.exit - -394: ; preds = %340 - br i1 %8, label %420, label %codeRepl.i1.i10 - -codeRepl.i1.i10: ; preds = %394 - %395 = and i8 %1, 8 - %396 = icmp eq i8 %395, 0 - %397 = and i8 %1, 4 - %398 = icmp eq i8 %397, 0 - %399 = and i8 %1, 2 - %400 = icmp eq i8 %399, 0 - %401 = and i8 %1, 1 - %402 = trunc i8 %401 to i3 - %403 = icmp eq i8 %401, 0 - %..i7.i92 = select i1 %403, i3 2, i3 3 - %.sink.i8.i93 = select i1 %400, i3 %402, i3 %..i7.i92 - br i1 %396, label %411, label %404 - -404: ; preds = %codeRepl.i1.i10 - %405 = zext i3 %.sink.i8.i93 to i4 - br i1 %398, label %408, label %codeRepl.i.i94 - -codeRepl.i.i94: ; preds = %404 - %406 = or i4 %405, -4 - %407 = zext i4 %406 to i5 - br label %__elem_3.exit97 - -408: ; preds = %404 - %409 = or i4 %405, -8 - %410 = zext i4 %409 to i5 - br label %__elem_3.exit97 - -411: ; preds = %codeRepl.i1.i10 - br i1 %398, label %414, label %codeRepl.i1.i96 - -codeRepl.i1.i96: ; preds = %411 - %412 = or i3 %.sink.i8.i93, -4 - %413 = zext i3 %412 to i5 - br label %__elem_3.exit97 - -414: ; preds = %411 - %415 = zext i3 %.sink.i8.i93 to i5 - br label %__elem_3.exit97 - -__elem_3.exit97: ; preds = %codeRepl.i.i94, %408, %codeRepl.i1.i96, %414 - %.sink17.i95 = phi i5 [ %413, %codeRepl.i1.i96 ], [ %415, %414 ], [ %410, %408 ], [ %407, %codeRepl.i.i94 ] - %416 = or i5 %.sink17.i95, -16 - %417 = zext i5 %416 to i6 - %418 = zext i6 %417 to i7 - %419 = zext i7 %418 to i8 - tail call void @putchar(i8 %419) - br label %__elem_0.4.exit - -420: ; preds = %394 - %421 = and i8 %1, 8 - %422 = icmp eq i8 %421, 0 - %423 = and i8 %1, 4 - %424 = icmp eq i8 %423, 0 - %425 = and i8 %1, 2 - %426 = icmp eq i8 %425, 0 - %427 = and i8 %1, 1 - %428 = trunc i8 %427 to i3 - %429 = icmp eq i8 %427, 0 - %..i7.i98 = select i1 %429, i3 2, i3 3 - %.sink.i8.i99 = select i1 %426, i3 %428, i3 %..i7.i98 - br i1 %422, label %437, label %430 - -430: ; preds = %420 - %431 = zext i3 %.sink.i8.i99 to i4 - br i1 %424, label %434, label %codeRepl.i.i100 - -codeRepl.i.i100: ; preds = %430 - %432 = or i4 %431, -4 - %433 = zext i4 %432 to i5 - br label %__elem_3.exit103 - -434: ; preds = %430 - %435 = or i4 %431, -8 - %436 = zext i4 %435 to i5 - br label %__elem_3.exit103 - -437: ; preds = %420 - br i1 %424, label %440, label %codeRepl.i1.i102 - -codeRepl.i1.i102: ; preds = %437 - %438 = or i3 %.sink.i8.i99, -4 - %439 = zext i3 %438 to i5 - br label %__elem_3.exit103 - -440: ; preds = %437 - %441 = zext i3 %.sink.i8.i99 to i5 - br label %__elem_3.exit103 - -__elem_3.exit103: ; preds = %codeRepl.i.i100, %434, %codeRepl.i1.i102, %440 - %.sink17.i101 = phi i5 [ %439, %codeRepl.i1.i102 ], [ %441, %440 ], [ %436, %434 ], [ %433, %codeRepl.i.i100 ] - %442 = zext i5 %.sink17.i101 to i6 - %443 = zext i6 %442 to i7 - %444 = zext i7 %443 to i8 - tail call void @putchar(i8 %444) - br label %__elem_0.4.exit } attributes #0 = { nofree nounwind } diff --git a/test/Golden/FunctionInIO.opt.ll b/test/Golden/FunctionInIO.opt.ll index 5df40bb..ecf8b76 100644 --- a/test/Golden/FunctionInIO.opt.ll +++ b/test/Golden/FunctionInIO.opt.ll @@ -5,16 +5,15 @@ declare i1 @getbit() local_unnamed_addr ; Function Attrs: norecurse nounwind readnone define i1 @main(i1) local_unnamed_addr #0 { - %not. = xor i1 %0, true - ret i1 %not. + %not..i = xor i1 %0, true + ret i1 %not..i } define i1 @main2() local_unnamed_addr { -__elem_0.exit: - %0 = tail call i1 @getbit() %1 = tail call i1 @getbit() - %2 = xor i1 %0, %1 - ret i1 %2 + %2 = tail call i1 @getbit() + %3 = xor i1 %1, %2 + ret i1 %3 } attributes #0 = { norecurse nounwind readnone } diff --git a/test/Golden/MemoryBit.opt.ll b/test/Golden/MemoryBit.opt.ll index 83fd937..63592fb 100644 --- a/test/Golden/MemoryBit.opt.ll +++ b/test/Golden/MemoryBit.opt.ll @@ -4,14 +4,8 @@ source_filename = "test/Golden/MemoryBit.elem" ; Function Attrs: nofree norecurse nounwind define void @main() local_unnamed_addr #0 { %1 = load volatile i1, i1* inttoptr (i14 -8192 to i1*), align 8192 - br i1 %1, label %2, label %3 - -2: ; preds = %0 - store volatile i1 false, i1* inttoptr (i14 -8192 to i1*), align 8192 - ret void - -3: ; preds = %0 - store volatile i1 true, i1* inttoptr (i14 -8192 to i1*), align 8192 + %not..i = xor i1 %1, true + store volatile i1 %not..i, i1* inttoptr (i14 -8192 to i1*), align 8192 ret void } diff --git a/test/Golden/NestedBranch.opt.ll b/test/Golden/NestedBranch.opt.ll index 3757558..0eb1584 100644 --- a/test/Golden/NestedBranch.opt.ll +++ b/test/Golden/NestedBranch.opt.ll @@ -5,12 +5,12 @@ declare void @dothing() local_unnamed_addr define void @main(i8) local_unnamed_addr { %2 = icmp eq i8 %0, 0 - br i1 %2, label %codeRepl.i, label %3 + br i1 %2, label %3, label %__elem_14.exit -3: ; preds = %codeRepl.i, %1 - ret void - -codeRepl.i: ; preds = %1 +3: ; preds = %1 tail call void @dothing() - br label %3 + br label %__elem_14.exit + +__elem_14.exit: ; preds = %1, %3 + ret void } diff --git a/test/Golden/NestedBranch2.opt.ll b/test/Golden/NestedBranch2.opt.ll index 1eac854..5595cb1 100644 --- a/test/Golden/NestedBranch2.opt.ll +++ b/test/Golden/NestedBranch2.opt.ll @@ -4,12 +4,12 @@ source_filename = "test/Golden/NestedBranch2.elem" declare void @dothing(i1) local_unnamed_addr define void @main(i1) local_unnamed_addr { - br i1 %0, label %2, label %3 + br i1 %0, label %2, label %__elem_0.exit 2: ; preds = %1 tail call void @dothing(i1 true) - ret void + br label %__elem_0.exit -3: ; preds = %1 +__elem_0.exit: ; preds = %1, %2 ret void } diff --git a/test/Golden/NestedBranch3.opt.ll b/test/Golden/NestedBranch3.opt.ll index 4344e1d..ebcfc6f 100644 --- a/test/Golden/NestedBranch3.opt.ll +++ b/test/Golden/NestedBranch3.opt.ll @@ -6,14 +6,14 @@ declare i2 @dothing() local_unnamed_addr define i1 @main() local_unnamed_addr { %1 = tail call i2 @dothing() %2 = icmp eq i2 %1, 0 - br i1 %2, label %__elem_0.exit, label %__elem_0.exit.sink.split + br i1 %2, label %__elem_2.exit, label %__elem_2.exit.sink.split -__elem_0.exit.sink.split: ; preds = %0 +__elem_2.exit.sink.split: ; preds = %0 %3 = tail call i2 @dothing() %4 = icmp ne i2 %3, 0 - br label %__elem_0.exit + br label %__elem_2.exit -__elem_0.exit: ; preds = %0, %__elem_0.exit.sink.split - %5 = phi i1 [ %4, %__elem_0.exit.sink.split ], [ false, %0 ] +__elem_2.exit: ; preds = %0, %__elem_2.exit.sink.split + %5 = phi i1 [ %4, %__elem_2.exit.sink.split ], [ false, %0 ] ret i1 %5 } diff --git a/test/Golden/ShareBindCont.opt.ll b/test/Golden/ShareBindCont.opt.ll index 0be4870..6920904 100644 --- a/test/Golden/ShareBindCont.opt.ll +++ b/test/Golden/ShareBindCont.opt.ll @@ -4,14 +4,12 @@ source_filename = "test/Golden/ShareBindCont.elem" declare i1 @getbit() local_unnamed_addr define i1 @main1() local_unnamed_addr { -__elem_0.exit: - %0 = tail call i1 @getbit() - ret i1 %0 + %1 = tail call i1 @getbit() + ret i1 %1 } define i1 @main2() local_unnamed_addr { -__elem_0.exit: - %0 = tail call i1 @getbit() - %not. = xor i1 %0, true - ret i1 %not. + %1 = tail call i1 @getbit() + %not..i.i = xor i1 %1, true + ret i1 %not..i.i } diff --git a/test/Golden/ShareIO.opt.ll b/test/Golden/ShareIO.opt.ll index cfb2aff..df885d2 100644 --- a/test/Golden/ShareIO.opt.ll +++ b/test/Golden/ShareIO.opt.ll @@ -6,19 +6,17 @@ declare void @putbit(i1) local_unnamed_addr declare i1 @getbit() local_unnamed_addr define void @main1() local_unnamed_addr { -__elem_2.exit: - %0 = tail call i1 @getbit() %1 = tail call i1 @getbit() - %.sink = xor i1 %0, %1 - tail call void @putbit(i1 %.sink) + %2 = tail call i1 @getbit() + %3 = xor i1 %1, %2 + tail call void @putbit(i1 %3) ret void } define void @main2() local_unnamed_addr { -__elem_2.exit: - %0 = tail call i1 @getbit() %1 = tail call i1 @getbit() - %.sink = xor i1 %0, %1 - tail call void @putbit(i1 %.sink) + %2 = tail call i1 @getbit() + %3 = xor i1 %1, %2 + tail call void @putbit(i1 %3) ret void } diff --git a/test/Golden/ShareIOPoly.opt.ll b/test/Golden/ShareIOPoly.opt.ll index 2c0d633..21305c1 100644 --- a/test/Golden/ShareIOPoly.opt.ll +++ b/test/Golden/ShareIOPoly.opt.ll @@ -8,12 +8,7 @@ define i1 @main1(i1 returned) local_unnamed_addr { ret i1 %0 } -define i2 @main2(i2) local_unnamed_addr { -__elem_1.exit: - %1 = icmp sgt i2 %0, -1 - %2 = and i2 %0, 1 +define i2 @main2(i2 returned) local_unnamed_addr { tail call void @dothing() - %3 = or i2 %0, -2 - %4 = select i1 %1, i2 %2, i2 %3 - ret i2 %4 + ret i2 %0 } From ed7cad3711dba6f8e5ffc0b02951cb6b3295fbb0 Mon Sep 17 00:00:00 2001 From: Alex Tunstall Date: Mon, 27 Jun 2022 17:00:40 +0100 Subject: [PATCH 17/17] Clean up unused functions --- src/Language/Elemental/InteractionNet.hs | 38 ------------------------ 1 file changed, 38 deletions(-) diff --git a/src/Language/Elemental/InteractionNet.hs b/src/Language/Elemental/InteractionNet.hs index 27ebe3a..3f1431e 100644 --- a/src/Language/Elemental/InteractionNet.hs +++ b/src/Language/Elemental/InteractionNet.hs @@ -1377,40 +1377,6 @@ commute2' mk1a mk1b mk2a mk2b r0 r1 r2 r3 = do linkNodes r3 $ Ref rn5 0 {-# INLINABLE commute2' #-} -commute2a - :: HasRewriter sig m - => (() -> () -> () -> () -> INetF ()) - -> (() -> () -> () -> INetF ()) - -> Ref -> Ref -> Ref -> Ref -> Ref -> m () -commute2a mk1 mk2 = commute2a' mk1 mk2 mk2 mk2 -{-# INLINABLE commute2a #-} - -commute2a' - :: HasRewriter sig m - => (() -> () -> () -> () -> INetF ()) - -> (() -> () -> () -> INetF ()) - -> (() -> () -> () -> INetF ()) - -> (() -> () -> () -> INetF ()) - -> Ref -> Ref -> Ref -> Ref -> Ref -> m () -commute2a' mk1 mk2a mk2b mk2c r0 r1 r2 r3 r4 = do - rn5 <- newNode $ mk1 () () () () - rn6 <- newNode $ mk1 () () () () - rn7 <- newNode $ mk2a () () () - rn8 <- newNode $ mk2b () () () - rn9 <- newNode $ mk2c () () () - linkNodes (Ref rn5 1) (Ref rn7 1) - linkNodes (Ref rn5 2) (Ref rn8 1) - linkNodes (Ref rn5 3) (Ref rn9 1) - linkNodes (Ref rn6 1) (Ref rn7 2) - linkNodes (Ref rn6 2) (Ref rn8 2) - linkNodes (Ref rn6 3) (Ref rn9 2) - linkNodes r0 $ Ref rn7 0 - linkNodes r1 $ Ref rn8 0 - linkNodes r2 $ Ref rn9 0 - linkNodes r3 $ Ref rn5 0 - linkNodes r4 $ Ref rn6 0 -{-# INLINABLE commute2a' #-} - commute2b :: HasRewriter sig m => (() -> () -> () -> () -> INetF ()) @@ -1440,10 +1406,6 @@ propagate2 :: HasRewriter sig m => Ref -> Ref -> (() -> INetF ()) -> m () propagate2 r0 r1 mk1 = propagate1 r0 mk1 *> propagate1 r1 mk1 {-# INLINABLE propagate2 #-} -propagate3 :: HasRewriter sig m => Ref -> Ref -> Ref -> (() -> INetF ()) -> m () -propagate3 r0 r1 r2 mk1 = propagate2 r0 r1 mk1 *> propagate1 r2 mk1 -{-# INLINABLE propagate3 #-} - dedupIO :: HasRewriter sig m => Level -> Ref -> Ref -> Ref -> m () dedupIO lvl r0 r1 r2 = do name <- newName