From 55982fcee37cbdb446000cd7b40505453ab02dab Mon Sep 17 00:00:00 2001 From: Olle Fredriksson Date: Thu, 27 Jun 2024 21:59:14 +0200 Subject: [PATCH] wip flattening --- src/Low/Syntax.hs | 4 +- src/Lower.hs | 205 ++++++++++++++++++--------------------- src/ReferenceCounting.hs | 142 +++++++++++++++------------ 3 files changed, 173 insertions(+), 178 deletions(-) diff --git a/src/Low/Syntax.hs b/src/Low/Syntax.hs index 4582622..f37c6ac 100644 --- a/src/Low/Syntax.hs +++ b/src/Low/Syntax.hs @@ -17,11 +17,11 @@ data Term v = Operand !(Operand v) | Let !PassBy !Name !(LetOperation v) !(Scope Term v) | Seq !(SeqOperation v) !(Term v) - | Case !(Operand v) [Branch v] (Maybe (Term v)) deriving (Eq, Show, Generic, Hashable) data LetOperation v - = Call !Name.Lowered [Operand v] + = Case !(Operand v) [Branch v] (Maybe (Term v)) + | Call !Name.Lowered [Operand v] | StackAllocate !(Operand v) | HeapAllocate !Name.QualifiedConstructor !(Operand v) | HeapPayload !(Operand v) diff --git a/src/Lower.hs b/src/Lower.hs index 3e19ead..a261bb3 100644 --- a/src/Lower.hs +++ b/src/Lower.hs @@ -45,11 +45,11 @@ data Value = Operand !Operand | Let !PassBy !Name !Var !LetOperation !Value | Seq !SeqOperation !Value - | Case !Operand [Branch] (Maybe Value) deriving (Show) data LetOperation - = Call !Name.Lowered [Operand ] + = Case !Operand [Branch] (Maybe Value) + | Call !Name.Lowered [Operand ] | StackAllocate !Operand | HeapAllocate !Name.QualifiedConstructor !Operand | HeapPayload !Operand @@ -61,8 +61,6 @@ data LetOperation data SeqOperation = Store !Operand !Operand !Representation | Copy !Operand !Operand !Operand - | IncreaseReferenceCount !Operand !Representation - | DecreaseReferenceCount !Operand !Representation deriving (Show) data Operand @@ -88,50 +86,31 @@ data OperandStorage = OperandStorage !Operand !OperandRepresentation deriving (Show) data Collectible - = CollectibleLet !PassBy !Name !Var !Value - | CollectibleSeq !Value + = CollectibleLet !PassBy !Name !Var !LetOperation + | CollectibleSeq !SeqOperation deriving (Show) data Function = Function [(Name, PassBy, Var)] !PassBy !Value type Collect = StateT (Tsil Collectible) M -let_ :: PassBy -> Name -> Value -> Collect Operand -let_ repr name = \case - Operand operand -> pure operand - value -> do +let_ :: PassBy -> Name -> LetOperation -> Collect Operand +let_ repr name operation = do var <- lift freshVar - modify (Tsil.:> CollectibleLet repr name var value) + modify (Tsil.:> CollectibleLet repr name var operation) pure $ Var var -letReference :: Name -> Value -> Collect Operand +letReference :: Name -> LetOperation -> Collect Operand letReference = let_ PassBy.Reference -letValue :: Representation -> Name -> Value -> Collect Operand -letValue repr name value = case repr of - Representation.Empty -> case value of - Operand _ -> pure $ Undefined repr - _ -> do - seq_ value - pure $ Undefined repr - _ -> let_ (PassBy.Value repr) name value +letValue :: Representation -> Name -> LetOperation -> Collect Operand +letValue = let_ . PassBy.Value -seq_ :: Value -> Collect () +seq_ :: SeqOperation -> Collect () seq_ value = modify (Tsil.:> CollectibleSeq value) -collect :: PassBy -> Name -> Collect Operand -> Collect Operand -collect repr name m = do - result <- lift $ runCollect m - let_ repr name result - -collectReference :: Name -> Collect Operand -> Collect Operand -collectReference = collect PassBy.Reference - -collectValue :: Representation -> Name -> Collect Operand -> Collect Operand -collectValue = collect . PassBy.Value - -runCollect :: Collect Operand -> M Value -runCollect = genRunCollect Operand (\_ v -> v) +collect :: Collect Operand -> M Value +collect = genRunCollect Operand (\_ v -> v) genRunCollect :: (a -> Value) -> (a -> Value -> b) -> Collect a -> M b genRunCollect f g m = do @@ -140,50 +119,47 @@ genRunCollect f g m = do g result $ foldr ( \case - CollectibleLet repr n var value -> mkLet repr n var value - CollectibleSeq value -> Seq value + CollectibleLet repr n var operation -> Let repr n var operation + CollectibleSeq operation -> Seq operation ) (f result) collectibles - where - mkLet _repr _name var value (Operand (Var var')) | var == var' = value - mkLet repr name var value body = Let repr name var value body - -mkCall :: Name.Lifted -> [Operand] -> Value -mkCall = \cases - (Name.Lifted Builtin.AddRepresentationName 0) [Representation x, Representation y] -> Operand $ Representation $ x <> y - (Name.Lifted Builtin.AddRepresentationName 0) [Representation Representation.Empty, y] -> Operand y - (Name.Lifted Builtin.AddRepresentationName 0) [x, Representation Representation.Empty] -> Operand x - (Name.Lifted Builtin.MaxRepresentationName 0) [Representation x, Representation y] -> Operand $ Representation $ Representation.leastUpperBound x y - (Name.Lifted Builtin.MaxRepresentationName 0) [Representation Representation.Empty, y] -> Operand y - (Name.Lifted Builtin.MaxRepresentationName 0) [x, Representation Representation.Empty] -> Operand x - name operands -> Call (Name.Lowered name Name.Original) operands + +letCall :: PassBy -> Name -> Name.Lifted -> [Operand] -> Collect Operand +letCall passBy name = \cases + (Name.Lifted Builtin.AddRepresentationName 0) [Representation x, Representation y] -> pure $ Representation $ x <> y + (Name.Lifted Builtin.AddRepresentationName 0) [Representation Representation.Empty, y] -> pure y + (Name.Lifted Builtin.AddRepresentationName 0) [x, Representation Representation.Empty] -> pure x + (Name.Lifted Builtin.MaxRepresentationName 0) [Representation x, Representation y] -> pure $ Representation $ Representation.leastUpperBound x y + (Name.Lifted Builtin.MaxRepresentationName 0) [Representation Representation.Empty, y] -> pure y + (Name.Lifted Builtin.MaxRepresentationName 0) [x, Representation Representation.Empty] -> pure x + global operands -> let_ passBy name $ Call (Name.Lowered global Name.Original) operands pattern Original :: Name.Qualified -> Name.Lowered pattern Original qname = Name.Lowered (Name.Lifted qname 0) Name.Original -mkLoad :: Operand -> Representation -> Value -mkLoad = \cases - (Global _ (Original Builtin.EmptyRepresentationName)) _ -> Operand $ Representation mempty - (Global _ (Original Builtin.PointerRepresentationName)) _ -> Operand $ Representation Representation.pointer - (Global _ (Original Builtin.UnitName)) _ -> Operand $ Representation mempty - (Global _ (Original Builtin.IntName)) _ -> Operand $ Representation Representation.int - _ Representation.Empty -> Operand $ Undefined Representation.Empty - operand repr -> Load operand repr +letLoad :: Name -> Operand -> Representation -> Collect Operand +letLoad name = \cases + (Global _ (Original Builtin.EmptyRepresentationName)) _ -> pure $ Representation mempty + (Global _ (Original Builtin.PointerRepresentationName)) _ -> pure $ Representation Representation.pointer + (Global _ (Original Builtin.UnitName)) _ -> pure $ Representation mempty + (Global _ (Original Builtin.IntName)) _ -> pure $ Representation Representation.int + _ Representation.Empty -> pure $ Undefined Representation.Empty + operand repr -> letValue repr name $ Load operand repr -mkStore :: Operand -> Operand -> Representation -> Maybe Value +mkStore :: Operand -> Operand -> Representation -> Maybe SeqOperation mkStore dst src = \case Representation.Empty -> Nothing repr -> Just $ Store dst src repr -addRepresentation :: Operand -> Operand -> Value -addRepresentation x y = - mkCall (Name.Lifted Builtin.AddRepresentationName 0) [x, y] +letAddRepresentation :: Name -> Operand -> Operand -> Collect Operand +letAddRepresentation name x y = + letCall (PassBy.Value Representation.type_) name (Name.Lifted Builtin.AddRepresentationName 0) [x, y] -mkOffset :: Operand -> Operand -> Value -mkOffset base = \case - Representation Representation.Empty -> Operand base - offset -> Offset base offset +letOffset :: Name -> Operand -> Operand -> Collect Operand +letOffset name base = \case + Representation Representation.Empty -> pure base + offset -> letReference name $ Offset base offset definition :: Name.Lifted -> CC.Syntax.Definition -> M [(Name.Lowered, Low.Syntax.Definition)] definition name = \case @@ -205,13 +181,13 @@ definition name = \case signature <- fetch $ Query.LowSignature name case signature of Low.Syntax.ConstantSignature repr -> do - initValue <- runCollect do + initValue <- collect do inited <- letValue Representation.int "inited" $ Load (Global Representation.int initedName) Representation.int - initBranch <- lift $ runCollect do + initBranch <- lift $ collect do seq_ $ Store (Global Representation.int initedName) (Literal $ Literal.Integer 1) Representation.int _ <- storeTerm CC.empty Index.Seq.Empty (Global repr (Name.Lowered name Name.Original)) term pure $ Undefined Representation.Empty - seq_ $ Case inited [LiteralBranch (Literal.Integer 0) initBranch] $ Just $ Operand $ Undefined Representation.Empty + letValue Representation.Empty "case_result" $ Case inited [LiteralBranch (Literal.Integer 0) initBranch] $ Just $ Operand $ Undefined Representation.Empty pure $ Undefined Representation.Empty let init = readback Index.Map.Empty initValue pure @@ -288,7 +264,7 @@ forceValue dstRepr (OperandStorage src srcOperandRepr) = when (dstRepr /= srcRepr) $ panic "repr mismatch" pure src Reference _srcReprValue -> - letValue dstRepr "loaded" $ mkLoad src dstRepr + letLoad "loaded" src dstRepr forceReference :: Maybe Name -> OperandStorage -> Collect Operand forceReference nameSuggestion (OperandStorage src srcOperandRepr) = @@ -360,25 +336,25 @@ storeTerm context indices dst = \case case branches' of CC.Representation.TaggedConstructorBranches Unboxed constrBranches -> do scrutineeRef <- forceReference Nothing scrutinee' - tag <- letValue Representation.int "tag" $ mkLoad scrutineeRef Representation.int - let payload name = letReference name $ mkOffset scrutineeRef $ Representation Representation.int + tag <- letLoad "tag" scrutineeRef Representation.int + let payload name = letOffset name scrutineeRef $ Representation Representation.int constrBranches' <- forM constrBranches \(constr, constrBranch) -> map (ConstructorBranch constr) $ lift $ - runCollect $ + collect $ storeBranch context indices dst payload constrBranch defaultBranch <- forM maybeDefault $ - lift . runCollect . storeTerm context indices dst + lift . collect . storeTerm context indices dst letValue Representation.type_ "result" $ Case tag constrBranches' defaultBranch CC.Representation.TaggedConstructorBranches Boxed constrBranches -> do scrutineeValue <- forceValue Representation.pointer scrutinee' tag <- letValue Representation.int "tag" $ PointerTag scrutineeValue let payload name = letReference name $ HeapPayload scrutineeValue constrBranches' <- forM constrBranches \(constr, constrBranch) -> - map (ConstructorBranch constr) $ lift $ runCollect do + map (ConstructorBranch constr) $ lift $ collect do storeBranch context indices dst payload constrBranch - defaultBranch <- forM maybeDefault $ lift . runCollect . storeTerm context indices dst + defaultBranch <- forM maybeDefault $ lift . collect . storeTerm context indices dst letValue Representation.type_ "result" $ Case tag constrBranches' defaultBranch CC.Representation.UntaggedConstructorBranch Unboxed constrBranch -> do let payload name = forceReference (Just name) scrutinee' @@ -392,9 +368,9 @@ storeTerm context indices dst = \case litBranches' <- forM (OrderedHashMap.toList litBranches) \(lit, litBranch) -> map (LiteralBranch lit) $ lift $ - runCollect $ + collect $ storeTerm context indices dst litBranch - defaultBranch <- forM maybeDefault $ lift . runCollect . storeTerm context indices dst + defaultBranch <- forM maybeDefault $ lift . collect . storeTerm context indices dst letValue Representation.type_ "result" $ Case scrutineeValue litBranches' defaultBranch storeConstrArgs @@ -408,9 +384,9 @@ storeConstrArgs context indices mdst offset = \case [] -> pure offset arg : args -> do dst <- mdst - argDst <- letReference "constr_arg_dst" $ mkOffset dst offset + argDst <- letOffset "constr_arg_dst" dst offset argSize <- storeTerm context indices argDst arg - offset' <- letValue Representation.type_ "constr_arg_offset" $ addRepresentation offset argSize + offset' <- letAddRepresentation "constr_arg_offset" offset argSize storeConstrArgs context indices (pure dst) offset' args storeConstrArgs_ @@ -425,9 +401,9 @@ storeConstrArgs_ context indices mdst moffset = \case arg : args -> do dst <- mdst offset <- moffset - argDst <- letReference "constr_arg_dst" $ mkOffset dst offset + argDst <- letOffset "constr_arg_dst" dst offset argSize <- storeTerm context indices argDst arg - let offset' = letValue Representation.type_ "constr_arg_offset" $ addRepresentation offset argSize + let offset' = letAddRepresentation "constr_arg_offset" offset argSize storeConstrArgs_ context indices (pure dst) offset' args generateTypeSize @@ -435,8 +411,7 @@ generateTypeSize -> Index.Seq v OperandStorage -> CC.Syntax.Type v -> Collect Operand -generateTypeSize context indices type_ = - collectValue Representation.type_ "size" $ do +generateTypeSize context indices type_ = do size <- generateTermWithType context Nothing indices type_ $ CC.Syntax.Global $ Name.Lifted Builtin.TypeName 0 forceValue Representation.type_ size @@ -512,11 +487,11 @@ generateTerm context nameSuggestion indices term typeValue = case term of CC.Syntax.Apply function args -> do signature <- fetch $ Query.LowSignature function case signature of - Low.Syntax.FunctionSignature passArgsBy (PassBy.Value returnRepr) -> do + Low.Syntax.FunctionSignature passArgsBy passReturnBy@(PassBy.Value returnRepr) -> do when (length passArgsBy /= length args) $ panic "arg length mismatch" let nonEmpty (PassBy.Value Representation.Empty) = False nonEmpty _ = True - callResult <- collectValue returnRepr (fromMaybe "call_result" nameSuggestion) do + callResult <- do callArgs <- forM (filter (nonEmpty . fst) $ zip passArgsBy args) \(passBy, arg) -> do operand <- generateTermWithoutType context indices arg case passBy of @@ -524,13 +499,13 @@ generateTerm context nameSuggestion indices term typeValue = case term of forceValue repr operand PassBy.Reference -> forceReference Nothing operand - letValue returnRepr (fromMaybe "call_result" nameSuggestion) $ mkCall function callArgs + letCall passReturnBy (fromMaybe "call_result" nameSuggestion) function callArgs pure $ OperandStorage callResult $ Value returnRepr Low.Syntax.FunctionSignature passArgsBy passReturnBy@PassBy.Reference -> do type_ <- lift $ Readback.readback (CC.toEnvironment context) typeValue size <- generateTypeSize context indices type_ callResult <- letReference (fromMaybe "call_destination" nameSuggestion) $ StackAllocate size - _ <- collectValue Representation.type_ "store_call" $ storeCall context indices callResult function args passArgsBy passReturnBy + _ <- storeCall context indices callResult function args passArgsBy passReturnBy pure $ OperandStorage callResult $ Reference size _ -> panic "Applying non-function" CC.Syntax.Pi _name _domain _target -> @@ -558,20 +533,19 @@ storeCall context indices dst function args passArgsBy passReturnBy = do when (length passArgsBy /= length args) $ panic "arg length mismatch" let nonEmpty (PassBy.Value Representation.Empty) = False nonEmpty _ = True - collectValue Representation.type_ "call_result" do - callArgs <- forM (filter (nonEmpty . fst) $ zip passArgsBy args) \(passBy, arg) -> do - operand <- generateTermWithoutType context indices arg - case passBy of - PassBy.Value repr -> - forceValue repr operand - PassBy.Reference -> - forceReference Nothing operand - case passReturnBy of - PassBy.Value repr -> do - callResult <- letValue repr "call_result" $ mkCall function callArgs - storeOperand dst $ OperandStorage callResult $ Value repr + callArgs <- forM (filter (nonEmpty . fst) $ zip passArgsBy args) \(passBy, arg) -> do + operand <- generateTermWithoutType context indices arg + case passBy of + PassBy.Value repr -> + forceValue repr operand PassBy.Reference -> - letValue Representation.type_ "call_result_size" $ mkCall function (dst : callArgs) + forceReference Nothing operand + case passReturnBy of + PassBy.Value repr -> do + callResult <- letCall passReturnBy "call_result" function callArgs + storeOperand dst $ OperandStorage callResult $ Value repr + PassBy.Reference -> + letCall passReturnBy "call_result_size" function (dst : callArgs) storeBranch :: CC.Context v @@ -588,7 +562,7 @@ storeBranch context indices dst mpayload = \case typeValue <- lift $ CC.Domain.Lazy <$> lazy (Evaluation.evaluate (CC.toEnvironment context) type_) (context', _) <- lift $ CC.extend context typeValue let indices' = indices Index.Seq.:> OperandStorage payload (Reference size) - let payload' name' = letReference name' $ mkOffset payload size + let payload' name' = letOffset name' payload size storeBranch context' indices' dst payload' tele boxedConstructorSize @@ -627,9 +601,9 @@ constantInitedName l = moduleInits :: [Name.Module] -> M Low.Syntax.Definition moduleInits moduleNames = do - value <- runCollect do + value <- collect do forM_ moduleNames \moduleName -> - seq_ $ Call (moduleInitName moduleName) [] + letValue Representation.Empty "init-result" $ Call (moduleInitName moduleName) [] pure $ Undefined Representation.Empty let term = readback Index.Map.Empty value pure $ Low.Syntax.FunctionDefinition $ Low.Syntax.Body (PassBy.Value Representation.Empty) term @@ -639,14 +613,14 @@ moduleInit -> [Name.Lowered] -> M [(Name.Lowered, Low.Syntax.Definition)] moduleInit moduleName definitions = do - initValue <- runCollect do + initValue <- collect do inited <- letValue Representation.int "inited" $ Load (Global Representation.int initedName) Representation.int - initBranch <- lift $ runCollect do + initBranch <- lift $ collect do seq_ $ Store (Global Representation.int initedName) (Literal $ Literal.Integer 1) Representation.int forM_ constantsToInitialize \defName -> - seq_ $ Call defName [] + letValue Representation.Empty "init-result" $ Call defName [] pure $ Undefined Representation.Empty - seq_ $ Case inited [LiteralBranch (Literal.Integer 0) initBranch] $ Just $ Operand $ Undefined Representation.Empty + letValue Representation.Empty "case-result" $ Case inited [LiteralBranch (Literal.Integer 0) initBranch] $ Just $ Operand $ Undefined Representation.Empty pure $ Undefined Representation.Empty let init = readback Index.Map.Empty initValue pure @@ -673,14 +647,17 @@ readbackFunction outerEnv (Function params returnRepr body) = readback :: Index.Map v Var -> Value -> Low.Syntax.Term v readback env = \case Operand operand -> Low.Syntax.Operand $ readbackOperand env operand - Let passBy name var value value' -> + Let passBy name var operation value' -> Low.Syntax.Let passBy name - (readback env value) + (readbackLetOperation env operation) (readback (env Index.Map.:> var) value') - Seq value value' -> - Low.Syntax.Seq (readback env value) (readback env value') + Seq operation value' -> + Low.Syntax.Seq (readbackSeqOperation env operation) (readback env value') + +readbackLetOperation :: Index.Map v Var -> LetOperation -> Low.Syntax.LetOperation v +readbackLetOperation env = \case Case scrutinee branches maybeDefaultBranch -> Low.Syntax.Case (readbackOperand env scrutinee) @@ -695,13 +672,16 @@ readback env = \case Low.Syntax.Offset (readbackOperand env base) (readbackOperand env offset) + Load src repr -> Low.Syntax.Load (readbackOperand env src) repr + +readbackSeqOperation :: Index.Map v Var -> SeqOperation -> Low.Syntax.SeqOperation v +readbackSeqOperation env = \case Copy dst src size -> Low.Syntax.Copy (readbackOperand env dst) (readbackOperand env src) (readbackOperand env size) Store dst value repr -> Low.Syntax.Store (readbackOperand env dst) (readbackOperand env value) repr - Load src repr -> Low.Syntax.Load (readbackOperand env src) repr readbackOperand :: Index.Map v Var -> Operand -> Low.Syntax.Operand v readbackOperand env = \case @@ -721,3 +701,4 @@ readbackBranch :: Index.Map v Var -> Branch -> Low.Syntax.Branch v readbackBranch env = \case ConstructorBranch con value -> Low.Syntax.ConstructorBranch con $ readback env value LiteralBranch lit value -> Low.Syntax.LiteralBranch lit $ readback env value + diff --git a/src/ReferenceCounting.hs b/src/ReferenceCounting.hs index 6b87a6b..9c51735 100644 --- a/src/ReferenceCounting.hs +++ b/src/ReferenceCounting.hs @@ -33,18 +33,24 @@ data Dead = NotDead | Dead data Value = Operand !Operand - | Let !PassBy !Name !Var !Dead !Value !Value - | Seq !Value !Value - | Case !Operand [(EnumSet Var, Branch)] (Maybe (EnumSet Var, Value)) + | Let !PassBy !Name !Var !Dead !LetOperation !Value + | Seq !SeqOperation !Value + deriving (Show) + +data LetOperation + = Case !Operand [(EnumSet Var, Branch)] (Maybe (EnumSet Var, Value)) | Call !Name.Lowered [Operand] | StackAllocate !Operand | HeapAllocate !Name.QualifiedConstructor !Operand | HeapPayload !Operand | PointerTag !Operand | Offset !Operand !Operand - | Copy !Operand !Operand !Operand - | Store !Operand !Operand !Representation | Load !Operand !Representation + deriving (Show) + +data SeqOperation + = Store !Operand !Operand !Representation + | Copy !Operand !Operand !Operand | IncreaseReferenceCount !Operand !Representation | DecreaseReferenceCount !Operand !Representation deriving (Show) @@ -94,23 +100,34 @@ referenceCountFunction env liveOut = \case function' <- referenceCountFunction (env Index.Map.:> var) (EnumSet.insert var liveOut) function pure $ Syntax.Parameter name passBy function' -evaluate :: Index.Map v Var -> EnumSet Var -> Syntax.Term v -> M (Value, EnumSet Var) +evaluate + :: Index.Map v Var + -> EnumSet Var + -> Syntax.Term v + -> M (Value, EnumSet Var) evaluate env liveOut = \case Syntax.Operand operand -> do let (operand', liveIn) = evaluateOperand env liveOut operand pure (Operand operand', liveIn) - Syntax.Let passBy name term body -> do + Syntax.Let passBy name operation body -> do var <- freshVar (body', bodyLiveIn) <- evaluate (env Index.Map.:> var) liveOut body - (term', liveIn) <- evaluate env bodyLiveIn term + (operation', liveIn) <- evaluateLetOperation env bodyLiveIn operation pure - ( Let passBy name var (if EnumSet.member var bodyLiveIn then NotDead else Dead) term' body' + ( Let passBy name var (if EnumSet.member var bodyLiveIn then NotDead else Dead) operation' body' , EnumSet.delete var liveIn ) Syntax.Seq lhs rhs -> do (rhs', rhsLiveIn) <- evaluate env liveOut rhs - (lhs', liveIn) <- evaluate env rhsLiveIn lhs + (lhs', liveIn) <- evaluateSeqOperation env rhsLiveIn lhs pure (Seq lhs' rhs', liveIn) + +evaluateLetOperation + :: Index.Map v Var + -> EnumSet Var + -> Syntax.LetOperation v + -> M (LetOperation, EnumSet Var) +evaluateLetOperation env liveOut = \case Syntax.Case scrutinee branches maybeDefaultBranch -> do branches' <- mapM (evaluateBranch env liveOut) branches maybeDefaultBranch' <- mapM (evaluate env liveOut) maybeDefaultBranch @@ -146,6 +163,16 @@ evaluate env liveOut = \case let (size', sizeLiveIn) = evaluateOperand env liveOut size let (ref', liveIn) = evaluateOperand env sizeLiveIn ref pure (Offset ref' size', liveIn) + Syntax.Load ref repr -> do + let (ref', liveIn) = evaluateOperand env liveOut ref + pure (Load ref' repr, liveIn) + +evaluateSeqOperation + :: Index.Map v Var + -> EnumSet Var + -> Syntax.SeqOperation v + -> M (SeqOperation, EnumSet Var) +evaluateSeqOperation env liveOut = \case Syntax.Copy dst src size -> do let (size', sizeLiveIn) = evaluateOperand env liveOut size let (src', srcLiveIn) = evaluateOperand env sizeLiveIn src @@ -155,9 +182,6 @@ evaluate env liveOut = \case let (src', srcLiveIn) = evaluateOperand env liveOut src let (dst', liveIn) = evaluateOperand env srcLiveIn dst pure (Store dst' src' repr, liveIn) - Syntax.Load ref repr -> do - let (ref', liveIn) = evaluateOperand env liveOut ref - pure (Load ref' repr, liveIn) Syntax.IncreaseReferenceCount {} -> panic "RC operations before reference counting" Syntax.DecreaseReferenceCount {} -> panic "RC operations before reference counting" @@ -207,16 +231,13 @@ referenceCount passBy value = case value of Representation _ -> pure (value, Nothing) Tag _ -> pure (value, Nothing) Undefined _ -> pure (value, Nothing) - Let passValBy name var dead val body -> do - (val', maybeValProvenance) <- referenceCount passValBy val - forM_ maybeValProvenance \valProvenance -> + Let passValBy name var dead operation body -> do + (operation', maybeOperationProvenance, decreaseAfters) <- referenceCountLetOperation passValBy val + forM_ maybeOperationProvenance \valProvenance -> modify \s -> s {provenances = EnumMap.insert var valProvenance s.provenances} - val'' <- case dead of - NotDead -> - pure val' - Dead -> do - decrease <- referenceCountOperand $ Var Killed var - decreaseAfter decrease val' passValBy + decreaseVar <- case dead of + NotDead -> pure Nothing + Dead -> referenceCountOperand $ Var Killed var (body', bodyProvenance) <- referenceCount passBy body modify \s -> s {provenances = EnumMap.delete var s.provenances} case bodyProvenance of @@ -234,6 +255,12 @@ referenceCount passBy value = case value of when (isJust lhsProvenance) $ panic $ "Seq with provenance " <> show lhs' (rhs', rhsProvenance) <- referenceCount passBy rhs pure (Seq lhs' rhs', rhsProvenance) + +referenceCountLetOperation + :: PassBy + -> LetOperation + -> ReferenceCount (LetOperation, Maybe Provenance, [(Var, Representation)]) +referenceCountLetOperation passBy operation = case operation of Case scrutinee branches maybeDefaultBranch -> do decreaseScrutinee <- referenceCountOperand scrutinee startingState <- get @@ -256,71 +283,58 @@ referenceCount passBy value = case value of (branch', provenance) <- referenceCount passBy branch when (isJust provenance) $ panic $ "Branch with provenance " <> show branch' pure (killedVars, decreaseBefore decreases branch') - value' <- decreaseAfter decreaseScrutinee (Case scrutinee branches' maybeDefaultBranch') passBy - pure (value', Nothing) + pure (Case scrutinee branches' maybeDefaultBranch', Nothing, maybeToList decreaseScrutinee) Call _ args -> do decreases <- catMaybes <$> mapM referenceCountOperand args - value' <- decreaseAfter decreases value passBy pure - ( value' + ( operation , case passBy of PassBy.Value repr | needsReferenceCounting repr -> Just $ Owned (PassBy.Value repr) 1 | otherwise -> Nothing PassBy.Reference -> Nothing + , decreases ) StackAllocate _ -> - pure (value, Just $ Owned PassBy.Reference 1) + pure (operation, Just $ Owned PassBy.Reference 1, []) HeapAllocate _ _ -> - pure (value, Just $ Owned (PassBy.Value Representation.pointer) 1) + pure (operation, Just $ Owned (PassBy.Value Representation.pointer) 1, []) HeapPayload pointer -> do + decrease <- referenceCountOperand pointer maybeParent <- tryMakeParent pointer - pure (value, Child <$> maybeParent) + pure (operation, Child <$> maybeParent, maybeToList decrease) PointerTag operand -> do decrease <- referenceCountOperand operand - value' <- decreaseAfter decrease value passBy - pure (value', Nothing) + pure (operation, Nothing, maybeToList decrease) Offset base _ -> do maybeParent <- tryMakeParent base - pure (value, Child <$> maybeParent) + pure (operation, Child <$> maybeParent, []) + Load src repr -> do + maybeParent <- + if needsReferenceCounting repr + then tryMakeParent src + else pure Nothing + decreaseSrc <- referenceCountOperand src + pure (operation, Child <$> maybeParent, maybeToList decreaseSrc) + +referenceCountSeqOperation + :: PassBy + -> SeqOperation + -> ReferenceCount ([(Var, Representation)], [(Var, Representation)]) +referenceCountSeqOperation passBy operation = case operation of Copy dst src _ -> do decreaseDst <- referenceCountOperand dst decreaseSrc <- referenceCountOperand src - value' <- decreaseAfter decreaseDst value passBy - value'' <- decreaseAfter decreaseSrc value' passBy - pure (value'', Nothing) - Store dst (Var Killed src) repr -> do - decreaseDst <- referenceCountOperand dst - decreaseSrc <- kill src - value' <- decreaseAfter decreaseDst value passBy - case decreaseSrc of - Just (var, _) | var == src -> do - pure (value', Nothing) - _ -> do - let value'' = increaseBefore (Var Killed src) repr value' - value''' <- decreaseAfter decreaseSrc value'' passBy - pure (value''', Nothing) + -- TODO + pure ([], catMaybes [decreaseDst decreaseSrc]) Store dst src repr -> do decreaseDst <- referenceCountOperand dst decreaseSrc <- referenceCountOperand src - let value' = increaseBefore src repr value - value'' <- decreaseAfter decreaseDst value' passBy - value''' <- decreaseAfter decreaseSrc value'' passBy - pure (value''', Nothing) - Load src repr - | needsReferenceCounting repr -> do - maybeParent <- tryMakeParent src - case maybeParent of - Nothing -> do - decrease <- referenceCountOperand src - value' <- decreaseAfter decrease value passBy - pure (value', Nothing) - Just parent -> do - pure (value, Just $ Child parent) - | otherwise -> do - decreaseSrc <- referenceCountOperand src - value' <- decreaseAfter decreaseSrc value passBy - pure (value', Nothing) + pure case (src, decreaseSrc) of + (Var Killed srcVar, Just (srcVar', _)) + | srcVar == srcVar' -> + ([], maybeToList decreaseDst) + _ -> ([(src, repr)], catMaybes [decreaseDst, decreaseSrc]) IncreaseReferenceCount {} -> panic "RC operations before reference counting" DecreaseReferenceCount {} -> panic "RC operations before reference counting"