From fff10e138531e545806d366ea0e9dfef13e5a2a6 Mon Sep 17 00:00:00 2001 From: Olle Fredriksson Date: Mon, 13 May 2024 23:39:28 +0200 Subject: [PATCH] wip --- src/Low/Representation.hs | 9 ++- src/Low/Syntax.hs | 4 +- src/Lower.hs | 126 +++++++++++++++++++++++++++----------- 3 files changed, 95 insertions(+), 44 deletions(-) diff --git a/src/Low/Representation.hs b/src/Low/Representation.hs index 0e7979b..1126553 100644 --- a/src/Low/Representation.hs +++ b/src/Low/Representation.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE PatternSynonyms #-} module Low.Representation where @@ -20,11 +21,9 @@ instance Semigroup Representation where } instance Monoid Representation where - mempty = - Representation - { pointers = 0 - , nonPointerBytes = 0 - } + mempty = Empty + +pattern Empty = Representation {pointers = 0, nonPointerBytes = 0} leastUpperBound :: Representation -> Representation -> Representation leastUpperBound repr1 repr2 = diff --git a/src/Low/Syntax.hs b/src/Low/Syntax.hs index 024d304..8358c0c 100644 --- a/src/Low/Syntax.hs +++ b/src/Low/Syntax.hs @@ -17,9 +17,9 @@ data Term v | Let !Name !(Term v) !(Scope Term v) | Seq !(Term v) !(Term v) | Case !(Operand v) [Branch v] (Maybe (Term v)) - | Call !Name.Qualified [Operand v] + | Call !Name.Lifted [Operand v] | StackAllocate !(Operand v) - | HeapAllocate !Name.QualifiedConstructor !(Operand v) + | HeapAllocate !Int !(Operand v) | Dereference !(Operand v) | PointerTag !(Operand v) | Offset !(Operand v) !(Operand v) diff --git a/src/Lower.hs b/src/Lower.hs index 14275fd..0ecc64f 100644 --- a/src/Lower.hs +++ b/src/Lower.hs @@ -32,6 +32,7 @@ import qualified Name import Protolude hiding (repr) import qualified Query import Rock.Core +import qualified Telescope import Var (Var) data Value @@ -41,7 +42,7 @@ data Value | Case !Operand [Branch] (Maybe Value) | Call !Name.Lifted [Operand] | StackAllocate !Operand - | HeapAllocate !Name.QualifiedConstructor !Operand + | HeapAllocate !Int !Operand | Dereference !Operand | PointerTag !Operand | Offset !Operand !Operand @@ -72,8 +73,11 @@ data Collectible type Collect = StateT (Tsil Collectible) M -let_ :: Name -> Var -> Value -> Collect () -let_ name var value = modify (Tsil.:> CollectibleLet name var value) +let_ :: Name -> Value -> Collect Var +let_ name value = do + var <- lift freshVar + modify (Tsil.:> CollectibleLet name var value) + pure var seq_ :: Value -> Collect () seq_ value = modify (Tsil.:> CollectibleSeq value) @@ -90,13 +94,15 @@ collect m = do value collectibles +addRepresentation :: Operand -> Operand -> Value +addRepresentation x y = + Call (Name.Lifted Builtin.AddRepresentationName 0) [x, y] + storeOperand - :: CC.Domain.Environment v - -> Index.Map v (PassedBy Operand) - -> Operand + :: Operand -> PassedBy Operand -> Collect Operand -storeOperand env indices dst (PassedBy src srcPassBy) = +storeOperand dst (PassedBy src srcPassBy) = case srcPassBy of PassBy.Value srcRepr -> do seq_ $ Store dst src srcRepr @@ -106,12 +112,6 @@ storeOperand env indices dst (PassedBy src srcPassBy) = seq_ $ Copy dst src srcReprOperand pure srcReprOperand --- srcReprTerm <- Readback.readback env srcReprValue --- collect do --- srcRepr <- generateTerm env indices srcReprTerm $ CC.Domain.global $ Name.Lifted Builtin.TypeName 0 --- srcReprValue <- forceValue Representation.type_ srcRepr --- pure $ Copy dst src srcReprValue - forceValue :: Representation -> PassedBy Operand @@ -122,8 +122,7 @@ forceValue dstRepr (PassedBy src srcPassBy) = when (dstRepr /= srcRepr) $ panic "repr mismatch" pure src PassBy.Reference _srcReprValue -> do - loaded <- lift freshVar - let_ "loaded" loaded $ Load src dstRepr + loaded <- let_ "loaded" $ Load src dstRepr pure $ Var loaded forceReference :: PassedBy Operand -> Collect Operand @@ -132,8 +131,7 @@ forceReference (PassedBy src srcPassBy) = PassBy.Reference _ -> pure src PassBy.Value srcRepr -> do - allocated <- lift freshVar - let_ "allocated" allocated $ StackAllocate $ Representation srcRepr + allocated <- let_ "allocated" $ StackAllocate $ Representation srcRepr seq_ $ Copy (Var allocated) src $ Representation srcRepr pure $ Var allocated @@ -146,7 +144,7 @@ storeTerm storeTerm env indices dst = \case CC.Syntax.Var index -> do let src = Index.Map.index indices index - storeOperand env indices dst src + storeOperand dst src CC.Syntax.Global global -> do signature <- fetch $ Query.LowSignature global case signature of @@ -162,27 +160,62 @@ storeTerm env indices dst = \case case boxity of Unboxed -> do let go argOffset arg = do - argDst <- lift freshVar - argOffset' <- lift freshVar - let_ "constr_arg_dst" argDst $ Offset dst argOffset - argSize <- storeTerm env indices argDst arg - let_ "constr_arg_offset" argOffset' $ Offset dst argOffset - let argOffset' + argDstVar <- let_ "constr_arg_dst" $ Offset dst argOffset + argSize <- storeTerm env indices (Var argDstVar) arg + argOffsetVar' <- let_ "constr_arg_offset" $ addRepresentation argOffset argSize + pure $ Var argOffsetVar' foldM go dst tagArgs - Boxed -> _ - CC.Syntax.Lit lit -> seq_ $ Store dst $ Literal lit + Boxed -> do + sizeTerm <- lift $ boxedConstructorSize env con typeParams args + size <- generateTerm env indices sizeTerm + sizeValue <- forceValue Representation.type_ size + pointer <- let_ "boxed_constr" $ HeapAllocate (fromMaybe 0 maybeTag) sizeValue + constrDst <- let_ "deref_constr" $ Dereference $ Var pointer + let go argOffset arg = do + argDstVar <- let_ "constr_arg_dst" $ Offset (Var constrDst) argOffset + argSize <- storeTerm env indices (Var argDstVar) arg + argOffsetVar' <- let_ "constr_arg_offset" $ addRepresentation argOffset argSize + pure $ Var argOffsetVar' + foldM go dst args + storeOperand dst $ PassedBy (Var pointer) $ PassBy.Value Representation.pointer + CC.Syntax.Lit lit@(Literal.Integer _) -> storeOperand dst $ PassedBy (Literal lit) $ PassBy.Value Representation.int CC.Syntax.Let name term type_ body -> do - type' <- Evaluation.evaluate env type_ - (env', var) <- Environment.extend env - termOperand <- generateTerm env indices term type' + type' <- lift $ Evaluation.evaluate env type_ + (env', var) <- lift $ Environment.extend env + termOperand <- generateTerm env indices term storeTerm env' (indices Index.Map.:> termOperand) dst body CC.Syntax.Function _ -> - storeOperand env indices dst $ - PassedBy (Representation Representation.rawFunctionPointer) PassBy.Value - CC.Syntax.Apply global args -> _ + storeOperand dst $ + PassedBy (Representation Representation.rawFunctionPointer) $ + PassBy.Value Representation.type_ + CC.Syntax.Apply function args -> do + signature <- fetch $ Query.LowSignature function + case signature of + Low.Syntax.FunctionSignature passArgsBy passReturnBy -> do + when (length passArgsBy /= length args) $ panic "arg length mismatch" + let nonEmpty (PassBy.Value Representation.Empty) = False + nonEmpty _ = True + call <- lift $ collect $ do + callArgs <- forM (filter (nonEmpty . fst) $ zip passArgsBy args) \(passBy, arg) -> do + operand <- generateTerm env indices arg + case passBy of + PassBy.Value repr -> + forceValue repr operand + PassBy.Reference () -> + forceReference operand + case passReturnBy of + PassBy.Value repr -> do + callResult <- let_ "call_result" $ Call function callArgs + repr <- storeOperand dst $ PassedBy (Var callResult) $ PassBy.Value repr + pure $ Operand repr + PassBy.Reference () -> + pure $ Call function (dst : callArgs) + Var <$> let_ "call_repr" call + _ -> panic "Applying non-function" CC.Syntax.Pi name domain target -> - storeOperand env indices dst $ - PassedBy (Representation Representation.pointer) PassBy.Value + storeOperand dst $ + PassedBy (Representation Representation.pointer) $ + PassBy.Value Representation.type_ CC.Syntax.Closure global args -> panic "TODO closure" CC.Syntax.ApplyClosure fun args -> panic "TODO closure" CC.Syntax.Case scrutinee type_ branches maybeDefault -> _ @@ -191,9 +224,8 @@ generateTerm :: CC.Domain.Environment v -> Index.Map v (PassedBy Operand) -> CC.Syntax.Term v - -> CC.Domain.Type -> Collect (PassedBy Operand) -generateTerm env indices term type_ = case term of +generateTerm env indices term = case term of CC.Syntax.Var index -> pure $ Index.Map.index indices index CC.Syntax.Global global -> do signature <- fetch $ Query.LowSignature global @@ -206,7 +238,7 @@ generateTerm env indices term type_ = case term of CC.Syntax.Let name term type_ body -> do type' <- lift $ Evaluation.evaluate env type_ (env', var) <- lift $ Environment.extend env - termOperand <- generateTerm env indices term type' + termOperand <- generateTerm env indices term generateTerm env' (indices Index.Map.:> termOperand) body CC.Syntax.Function tele -> pure $ PassedBy (Reresentation Representation.rawFunctionPointer) PassBy.Value @@ -218,6 +250,26 @@ generateTerm env indices term type_ = case term of CC.Syntax.ApplyClosure fun args -> panic "TODO closure" CC.Syntax.Case scrutinee type_ branches maybeDefault -> _ +boxedConstructorSize + :: CC.Domain.Environment v + -> Name.QualifiedConstructor + -> [CC.Syntax.Term v] + -> [CC.Syntax.Term v] + -> M (CC.Syntax.Term v) +boxedConstructorSize env con params args = do + tele <- fetch $ Query.ClosureConvertedConstructorType con + params' <- mapM (Evaluation.evaluate env) params + args' <- mapM (Evaluation.evaluate env) args + maybeResult <- Evaluation.applyTelescope env (Telescope.fromVoid tele) params' \env' type_ -> do + type' <- Evaluation.evaluate env' type_ + size <- CC.Representation.compileBoxedConstructorFields env' type' args' + Evaluation.evaluate env' size + case maybeResult of + Nothing -> panic "boxedConstructorSize: Data params length mismatch" + Just result -> Readback.readback env result + +------------------------------------------------------------------------------- + readback :: Index.Map v Var -> Value -> Low.Syntax.Term v readback env = \case Operand voperand -> Low.Syntax.Operand $ readbackOperand env operand