From f91c527d2c2bee63cb73fa62e81214178e92e9a5 Mon Sep 17 00:00:00 2001 From: Olle Fredriksson Date: Tue, 21 May 2024 23:37:32 +0200 Subject: [PATCH] Add some smart constructors --- src/Lower.hs | 56 ++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 39 insertions(+), 17 deletions(-) diff --git a/src/Lower.hs b/src/Lower.hs index cd07b42..b96e641 100644 --- a/src/Lower.hs +++ b/src/Lower.hs @@ -87,10 +87,12 @@ data Function = Function [(Name, PassBy, Var)] !PassBy !Value type Collect = StateT (Tsil Collectible) M let_ :: PassBy -> Name -> Value -> Collect Operand -let_ repr name value = do - var <- lift freshVar - modify (Tsil.:> CollectibleLet repr name var value) - pure $ Var var +let_ repr name = \case + Operand operand -> pure operand + value -> do + var <- lift freshVar + modify (Tsil.:> CollectibleLet repr name var value) + pure $ Var var letReference :: Name -> Value -> Collect Operand letReference = let_ PassBy.Reference @@ -104,9 +106,7 @@ seq_ value = modify (Tsil.:> CollectibleSeq value) collect :: PassBy -> Name -> Collect Operand -> Collect Operand collect repr name m = do result <- lift $ runCollect m - case result of - Operand operand -> pure operand - _ -> let_ repr name result + let_ repr name result collectReference :: Name -> Collect Operand -> Collect Operand collectReference = collect PassBy.Reference @@ -133,9 +133,31 @@ genRunCollect f g m = do 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 x, y] | x == mempty -> Operand y + (Name.Lifted Builtin.AddRepresentationName 0) [x, Representation y] | y == mempty -> Operand x + (Name.Lifted Builtin.MaxRepresentationName 0) [Representation x, Representation y] -> Operand $ Representation $ Representation.leastUpperBound x y + (Name.Lifted Builtin.MaxRepresentationName 0) [Representation x, y] | x == mempty -> Operand y + (Name.Lifted Builtin.MaxRepresentationName 0) [x, Representation y] | y == mempty -> Operand x + name operands -> Call name operands + +mkLoad :: Operand -> Representation -> Value +mkLoad = \cases + (Global (Name.Lifted Builtin.EmptyRepresentationName 0)) _ -> Operand $ Representation mempty + (Global (Name.Lifted Builtin.UnitName 0)) _ -> Operand $ Representation mempty + (Global (Name.Lifted Builtin.IntName 0)) _ -> Operand $ Representation Representation.int + operand repr -> Load operand repr + addRepresentation :: Operand -> Operand -> Value addRepresentation x y = - Call (Name.Lifted Builtin.AddRepresentationName 0) [x, y] + mkCall (Name.Lifted Builtin.AddRepresentationName 0) [x, y] + +mkOffset :: Operand -> Operand -> Value +mkOffset base = \case + Representation x | x == mempty -> Operand base + offset -> Offset base offset definition :: Name.Lifted -> CC.Syntax.Definition -> M (Maybe Low.Syntax.Definition) definition name = \case @@ -227,7 +249,7 @@ forceValue dstRepr (OperandStorage src srcOperandRepr) = when (dstRepr /= srcRepr) $ panic "repr mismatch" pure src Reference _srcReprValue -> - letValue dstRepr "loaded" $ Load src dstRepr + letValue dstRepr "loaded" $ mkLoad src dstRepr forceReference :: OperandStorage -> Collect Operand forceReference (OperandStorage src srcOperandRepr) = @@ -264,7 +286,7 @@ storeTerm context indices dst = \case case boxity of Unboxed -> do let go argOffset arg = do - argDst <- letReference "constr_arg_dst" $ Offset dst argOffset + argDst <- letReference "constr_arg_dst" $ mkOffset dst argOffset argSize <- storeTerm context indices argDst arg letValue Representation.type_ "constr_arg_offset" $ addRepresentation argOffset argSize foldM go dst tagArgs @@ -274,7 +296,7 @@ storeTerm context indices dst = \case pointer <- letValue Representation.pointer "boxed_constr" $ HeapAllocate con size constrDst <- letReference "payload" $ HeapPayload pointer let go argOffset arg = do - argDst <- letValue Representation.type_ "constr_arg_dst" $ Offset constrDst argOffset + argDst <- letValue Representation.type_ "constr_arg_dst" $ mkOffset constrDst argOffset argSize <- storeTerm context indices argDst arg letValue Representation.type_ "constr_arg_offset" $ addRepresentation argOffset argSize foldM_ go dst args @@ -307,8 +329,8 @@ storeTerm context indices dst = \case case branches' of CC.Representation.TaggedConstructorBranches Unboxed constrBranches -> do scrutineeRef <- forceReference scrutinee' - tag <- letValue Representation.int "tag" $ Load scrutineeRef Representation.int - payload <- letReference "payload" $ Offset scrutineeRef $ Representation Representation.int + tag <- letValue Representation.int "tag" $ mkLoad scrutineeRef Representation.int + payload <- letReference "payload" $ mkOffset scrutineeRef $ Representation Representation.int constrBranches' <- forM constrBranches \(constr, constrBranch) -> map (ConstructorBranch constr) $ lift $ @@ -406,7 +428,7 @@ generateTerm context indices term typeValue = case term of unboxedCon <- letReference "unboxed_constr" $ StackAllocate size let go argOffset arg = do - argDst <- letReference "constr_arg_dst" $ Offset unboxedCon argOffset + argDst <- letReference "constr_arg_dst" $ mkOffset unboxedCon argOffset argSize <- storeTerm context indices argDst arg letValue Representation.type_ "constr_arg_offset" $ addRepresentation argOffset argSize _ <- collectValue Representation.type_ "constr_fields" $ foldM go (Representation mempty) tagArgs @@ -417,7 +439,7 @@ generateTerm context indices term typeValue = case term of pointer <- letValue Representation.pointer "boxed_constr" $ HeapAllocate con size constrDst <- letReference "deref_constr" $ HeapPayload pointer let go argOffset arg = do - argDst <- letReference "constr_arg_dst" $ Offset constrDst argOffset + argDst <- letReference "constr_arg_dst" $ mkOffset constrDst argOffset argSize <- storeTerm context indices argDst arg letValue Representation.type_ "constr_arg_offset" $ addRepresentation argOffset argSize _ <- collectValue Representation.type_ "constr_fields" $ foldM go (Representation mempty) args @@ -445,7 +467,7 @@ generateTerm context indices term typeValue = case term of forceValue repr operand PassBy.Reference -> forceReference operand - letValue returnRepr "call_result" $ Call function callArgs + letValue returnRepr "call_result" $ mkCall function callArgs pure $ OperandStorage callResult $ Value returnRepr Low.Syntax.FunctionSignature passArgsBy passReturnBy@PassBy.Reference -> do type_ <- lift $ Readback.readback (CC.toEnvironment context) typeValue @@ -508,7 +530,7 @@ storeBranch context indices dst payload = \case typeValue <- lift $ CC.Domain.Lazy <$> lazy (Evaluation.evaluate (CC.toEnvironment context) type_) (context', _) <- lift $ CC.extend context typeValue let indices' = indices Seq.:|> OperandStorage payload (Reference size) - payload' <- letReference "offset_payload" $ Offset payload size + payload' <- letReference "offset_payload" $ mkOffset payload size storeBranch context' indices' dst payload' tele boxedConstructorSize