From 6b2fc1d2efcd288b4532d906f255b140b50d13a9 Mon Sep 17 00:00:00 2001 From: Olle Fredriksson Date: Tue, 7 May 2024 23:30:24 +0200 Subject: [PATCH] wip --- src/ClosureConverted/Representation2.hs | 346 ++++++++++++++++++++++++ src/Low/Representation.hs | 36 +++ src/Low/Syntax.hs | 4 +- src/Lower.hs | 143 ++++++---- src/Query.hs | 17 +- src/Rules.hs | 5 + 6 files changed, 496 insertions(+), 55 deletions(-) create mode 100644 src/ClosureConverted/Representation2.hs diff --git a/src/ClosureConverted/Representation2.hs b/src/ClosureConverted/Representation2.hs new file mode 100644 index 0000000..bed4e53 --- /dev/null +++ b/src/ClosureConverted/Representation2.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} + +module ClosureConverted.Representation2 where + +import Boxity +import qualified Builtin +import ClosureConverted.Context (Context) +import qualified ClosureConverted.Context as Context +import qualified ClosureConverted.Domain as Domain +import qualified ClosureConverted.Evaluation as Evaluation +import qualified ClosureConverted.Readback as Readback +import qualified ClosureConverted.Syntax as Syntax +import qualified ClosureConverted.TypeOf as TypeOf +import qualified Core.Syntax +import Data.HashMap.Lazy (HashMap) +import qualified Data.HashMap.Lazy as HashMap +import qualified Data.OrderedHashMap as OrderedHashMap +import Data.Tsil (Tsil) +import qualified Data.Tsil as Tsil +import qualified Environment +import Low.PassBy (PassBy) +import qualified Low.PassBy +import qualified Low.PassBy as PassBy +import Low.Representation (Representation) +import qualified Low.Representation +import qualified Low.Representation as Representation +import qualified Low.Syntax as Low +import Monad +import Name (Name) +import qualified Name +import Protolude hiding (empty, force) +import Query (Query) +import qualified Query +import Rock +import Telescope (Telescope) +import qualified Telescope + +signature :: Syntax.Definition -> M Low.Signature +signature def = + case def of + Syntax.TypeDeclaration (Syntax.Function tele) -> do + telescopeSignature context tele mempty \context' body passParametersBy -> do + let env' = Context.toEnvironment context' + body' <- Evaluation.evaluate env' body + passReturnBy <- passTypeBy env' body' + pure $ Low.FunctionSignature (functionOperand <$> passParametersBy) $ functionOperand passReturnBy + Syntax.TypeDeclaration type_ -> do + type' <- Evaluation.evaluate env type_ + passBy <- passTypeBy env type' + case passBy of + PassBy.Value repr -> + pure $ Low.ConstantSignature repr + PassBy.Reference () -> panic "couldn't determine representation of type declaration" -- TODO real error? + Syntax.ConstantDefinition term -> do + value <- Evaluation.evaluate env term + type_ <- TypeOf.typeOf context value + passBy <- passTypeBy env type_ + case passBy of + PassBy.Value repr -> + pure $ Low.ConstantSignature repr + PassBy.Reference () -> panic "couldn't determine representation of constant definition" -- TODO real error? + Syntax.FunctionDefinition tele -> + telescopeSignature context tele mempty \context' body passParametersBy -> do + let env' = Context.toEnvironment context' + body' <- Evaluation.evaluate env' body + type_ <- TypeOf.typeOf context' body' + passReturnBy <- passTypeBy env' type_ + pure $ Low.FunctionSignature (functionOperand <$> passParametersBy) $ functionOperand passReturnBy + Syntax.DataDefinition {} -> + pure $ Low.ConstantSignature Representation.type_ + Syntax.ParameterisedDataDefinition _boxity tele -> + telescopeSignature context tele mempty \_ _ passParametersBy -> do + pure $ Low.FunctionSignature (functionOperand <$> passParametersBy) $ functionOperand $ PassBy.Value Representation.type_ + where + functionOperand passBy@(PassBy.Value repr) + | Representation.shouldPassByReference repr = PassBy.Reference () + | otherwise = passBy + functionOperand passBy@(PassBy.Reference ()) = passBy + + context = Context.empty + env = Context.toEnvironment context + +telescopeSignature + :: Context v + -> Telescope Name Syntax.Type body v + -> Tsil (PassBy ()) + -> (forall v'. Context v' -> body v' -> [PassBy ()] -> M result) + -> M result +telescopeSignature context tele passBys k = + case tele of + Telescope.Empty body -> + k context body $ toList passBys + Telescope.Extend _name type_ _plicity tele' -> do + let env = + Context.toEnvironment context + type' <- Evaluation.evaluate env type_ + passBy <- passTypeBy env type' + (context', _var) <- Context.extend context type' + telescopeSignature context' tele' (passBys Tsil.:> passBy) k + +type Environment = Environment.Environment Domain.Type + +passTypeBy :: Environment v -> Domain.Type -> M (PassBy ()) +passTypeBy env type_ = + case type_ of + Domain.Neutral (Domain.Var _) _ -> + pure $ PassBy.Reference () + -- TODO: Handle these special cases in a nicer way + Domain.Neutral (Domain.Global (Name.Lifted Builtin.TypeName 0)) Tsil.Empty -> + pure $ PassBy.Value Representation.type_ + Domain.Neutral (Domain.Global (Name.Lifted Builtin.IntName 0)) Tsil.Empty -> + pure $ PassBy.Value Representation.int + Domain.Neutral (Domain.Global global) (Domain.groupSpine -> [Domain.GroupedApps args]) -> do + globalCase global args + Domain.Neutral (Domain.Global global) (Domain.groupSpine -> []) -> do + globalCase global [] + Domain.Neutral {} -> + pure $ PassBy.Reference () + Domain.Con {} -> + pure $ PassBy.Reference () + Domain.Lit {} -> + pure $ PassBy.Reference () + Domain.Glued _ _ type' -> + passTypeBy env type' + Domain.Lazy lazyType -> do + type' <- force lazyType + passTypeBy env type' + Domain.Pi {} -> + pure $ PassBy.Value Representation.pointer + Domain.Function {} -> + pure $ PassBy.Value Representation.rawFunctionPointer + where + globalCase global@(Name.Lifted qualifiedName liftedNameNumber) args = do + -- TODO caching + definition <- fetch $ Query.ClosureConverted global + case definition of + Syntax.TypeDeclaration _ -> + pure $ PassBy.Reference () + Syntax.ConstantDefinition term -> do + value <- Evaluation.evaluate Environment.empty term + type' <- Evaluation.apply env value args + passTypeBy env type' + Syntax.FunctionDefinition tele -> do + maybeType' <- Evaluation.applyFunction env (Telescope.fromVoid tele) args + case maybeType' of + Nothing -> + pure $ PassBy.Value Representation.pointer -- a closure + Just type' -> + passTypeBy env type' + Syntax.DataDefinition Boxed _ -> + pure $ PassBy.Value Representation.pointer + Syntax.DataDefinition Unboxed constructors -> do + unless (liftedNameNumber == 0) $ panic "ClosureConverted.Representation. Data with name number /= 0" + passUnboxedDataBy qualifiedName Environment.empty constructors + Syntax.ParameterisedDataDefinition Boxed _ -> + pure $ PassBy.Value Representation.pointer + Syntax.ParameterisedDataDefinition Unboxed tele -> do + unless (liftedNameNumber == 0) $ panic "ClosureConverted.Representation. Data with name number /= 0" + maybeResult <- Evaluation.applyTelescope env (Telescope.fromVoid tele) args $ passUnboxedDataBy qualifiedName + pure $ fromMaybe (PassBy.Reference ()) maybeResult + +maxM :: Monad m => [m (PassBy ())] -> m (PassBy ()) +maxM = go mempty + where + go repr [] = pure $ PassBy.Value mempty + go repr (m : ms) = do + passBy <- m + case passBy of + PassBy.Reference () -> pure passBy + PassBy.Value repr' -> go (Representation.leastUpperBound repr repr') ms + +passProductBy :: PassBy () -> PassBy () -> PassBy () +passProductBy (PassBy.Value repr1) (PassBy.Value repr2) = PassBy.Value $ repr1 <> repr2 +passProductBy (PassBy.Reference ()) _ = PassBy.Reference () +passProductBy _ (PassBy.Reference ()) = PassBy.Reference () + +passUnboxedDataBy :: Name.Qualified -> Environment v -> Syntax.ConstructorDefinitions v -> M (PassBy ()) +passUnboxedDataBy dataTypeName env (Syntax.ConstructorDefinitions constructors) = do + (_boxity, maybeTags) <- fetch $ Query.ConstructorRepresentations dataTypeName + passFieldsBy <- + maxM + [ do + type' <- Evaluation.evaluate env type_ + passConstructorFieldsBy env type' $ PassBy.Value mempty + | (_, type_) <- OrderedHashMap.toList constructors + ] + pure case maybeTags of + Nothing -> passFieldsBy + Just _ -> passProductBy passConstructorTagBy passFieldsBy + where + passConstructorTagBy = + PassBy.Value Representation.int + +passConstructorFieldsBy :: Environment v -> Domain.Type -> PassBy () -> M (PassBy ()) +passConstructorFieldsBy env type_ accumulatedPassBy = do + type' <- Evaluation.forceHead type_ + case type' of + Domain.Pi _ fieldType closure -> do + passFieldBy <- passTypeBy env fieldType + case passProductBy accumulatedPassBy passFieldBy of + passBy@(PassBy.Reference ()) -> + pure passBy + accumulatedPassBy' -> do + (context', var) <- Environment.extend env + type'' <- Evaluation.evaluateClosure closure $ Domain.var var + passConstructorFieldsBy context' type'' accumulatedPassBy' + Domain.Neutral {} -> + pure accumulatedPassBy + Domain.Con {} -> + pure accumulatedPassBy + Domain.Lit {} -> + pure accumulatedPassBy + Domain.Glued {} -> + pure accumulatedPassBy + Domain.Lazy {} -> + pure accumulatedPassBy + Domain.Function {} -> + pure accumulatedPassBy + +------------------------------------------------------------------------------- +compileData :: Environment v -> Name.Qualified -> Syntax.ConstructorDefinitions v -> M (Syntax.Term v) +compileData env dataTypeName (Syntax.ConstructorDefinitions constructors) = do + (boxity, maybeTags) <- fetch $ Query.ConstructorRepresentations dataTypeName + case boxity of + Boxed -> + pure $ Syntax.Global (Name.Lifted Builtin.WordRepresentationName 0) + Unboxed -> do + compiledConstructorFields <- forM (OrderedHashMap.toList constructors) \(_, type_) -> do + type' <- Evaluation.evaluate env type_ + compileUnboxedConstructorFields env type' + let maxFieldSize = + foldr + (\a b -> Syntax.Apply (Name.Lifted Builtin.MaxRepresentationName 0) [a, b]) + (Syntax.Global $ Name.Lifted Builtin.EmptyRepresentationName 0) + compiledConstructorFields + pure case maybeTags of + Nothing -> maxFieldSize + Just _ -> + Syntax.Apply + (Name.Lifted Builtin.AddRepresentationName 0) + [ Syntax.Global (Name.Lifted Builtin.WordRepresentationName 0) + , maxFieldSize + ] + +compileParameterisedData + :: Environment v + -> Name.Qualified + -> Telescope Name Syntax.Type Syntax.ConstructorDefinitions v + -> M (Telescope Name Syntax.Type Syntax.Term v) +compileParameterisedData env dataTypeName tele = + case tele of + Telescope.Empty constructors -> + Telescope.Empty <$> compileData env dataTypeName constructors + Telescope.Extend name type_ plicity tele' -> do + (env', _) <- Environment.extend env + Telescope.Extend name type_ plicity <$> compileParameterisedData env' dataTypeName tele' + +compileUnboxedConstructorFields :: Environment v -> Domain.Type -> M (Syntax.Term v) +compileUnboxedConstructorFields env type_ = do + type' <- Evaluation.forceHead type_ + case type' of + Domain.Pi _name fieldType closure -> do + fieldType' <- Readback.readback env fieldType + value <- Domain.Lazy <$> lazy (panic "unboxed data representation depends on field") -- TODO real error + rest <- Evaluation.evaluateClosure closure value + rest' <- compileUnboxedConstructorFields env rest + pure $ Syntax.Apply (Name.Lifted Builtin.AddRepresentationName 0) [fieldType', rest'] + Domain.Neutral {} -> + empty + Domain.Con {} -> + empty + Domain.Lit {} -> + empty + Domain.Glued {} -> + empty + Domain.Lazy {} -> + empty + Domain.Function {} -> + empty + where + empty = + pure $ Syntax.Global (Name.Lifted Builtin.EmptyRepresentationName 0) + +compileBoxedConstructorFields :: Environment v -> Domain.Type -> [Domain.Value] -> M (Syntax.Term v) +compileBoxedConstructorFields env type_ args = do + type' <- Evaluation.forceHead type_ + case (type', args) of + (Domain.Pi _name fieldType closure, arg : args') -> do + fieldType' <- Readback.readback env fieldType + rest <- Evaluation.evaluateClosure closure arg + rest' <- compileBoxedConstructorFields env rest args' + pure $ Syntax.Apply (Name.Lifted Builtin.AddRepresentationName 0) [fieldType', rest'] + (Domain.Pi {}, []) -> + panic "compileBoxedConstructorFields: constructor type field mismatch" + (Domain.Neutral {}, []) -> empty + (Domain.Con {}, []) -> empty + (Domain.Lit {}, []) -> empty + (Domain.Glued {}, []) -> empty + (Domain.Lazy {}, []) -> empty + (Domain.Function {}, []) -> empty + (_, _ : _) -> + panic "compileBoxedConstructorFields: constructor type field mismatch" + where + empty = pure $ Syntax.Global (Name.Lifted Builtin.EmptyRepresentationName 0) + +------------------------------------------------------------------------------- +data Branches v + = LiteralBranches (Syntax.LiteralBranches v) + | UntaggedConstructorBranch !Boxity (Telescope Name Syntax.Type Syntax.Term v) + | TaggedConstructorBranches !Boxity [(Int, Telescope Name Syntax.Type Syntax.Term v)] + deriving (Eq, Show) + +compileBranches :: (MonadFetch Query m) => Syntax.Branches v -> m (Branches v) +compileBranches branches = + case branches of + Syntax.LiteralBranches literalBranches -> pure $ LiteralBranches literalBranches + Syntax.ConstructorBranches typeName constructorBranches -> do + (boxity, maybeTags) <- fetch $ Query.ConstructorRepresentations typeName + pure case (maybeTags, OrderedHashMap.toList constructorBranches) of + (Nothing, [(_, constructorBranch)]) -> UntaggedConstructorBranch boxity constructorBranch + (Nothing, _) -> panic "ClosureConverted.Representation.compileBranches: Untagged constructor branch length mismatch" + (Just tags, constructorBranchesList) -> + TaggedConstructorBranches + boxity + [(tags HashMap.! constructor, branch) | (constructor, branch) <- constructorBranchesList] + +constructorRepresentations :: Name.Qualified -> Task Query (Boxity, Maybe (HashMap Name.Constructor Int)) +constructorRepresentations name = do + (definition, _) <- fetch $ Query.ElaboratedDefinition name + pure case definition of + Core.Syntax.DataDefinition boxity tele -> + ( boxity + , Telescope.under tele \(Core.Syntax.ConstructorDefinitions constructors) -> + case OrderedHashMap.toList constructors of + [] -> Nothing + [_] -> Nothing + constructorList -> + Just $ + HashMap.fromList [(constructor, tag) | (tag, (constructor, _)) <- zip [0 ..] constructorList] + ) + _ -> + panic "ClosureConverted.Representation.compileConstructors: No data definition" diff --git a/src/Low/Representation.hs b/src/Low/Representation.hs index cc9811b..0e7979b 100644 --- a/src/Low/Representation.hs +++ b/src/Low/Representation.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedRecordDot #-} module Low.Representation where @@ -11,8 +12,43 @@ data Representation = Representation } deriving (Eq, Show, Generic, Hashable) +instance Semigroup Representation where + repr1 <> repr2 = + Representation + { pointers = repr1.pointers + repr2.pointers + , nonPointerBytes = repr1.nonPointerBytes + repr2.nonPointerBytes + } + +instance Monoid Representation where + mempty = + Representation + { pointers = 0 + , nonPointerBytes = 0 + } + +leastUpperBound :: Representation -> Representation -> Representation +leastUpperBound repr1 repr2 = + Representation + { pointers = max repr1.pointers repr2.pointers + , nonPointerBytes = + max repr1.nonPointerBytes repr2.nonPointerBytes + } + wordBytes :: Int wordBytes = 8 +int :: Representation +int = Representation {pointers = 0, nonPointerBytes = wordBytes} + type_ :: Representation type_ = Representation {pointers = 0, nonPointerBytes = wordBytes} + +pointer :: Representation +pointer = Representation {pointers = 1, nonPointerBytes = 0} + +rawFunctionPointer :: Representation +rawFunctionPointer = Representation {pointers = 0, nonPointerBytes = wordBytes} + +shouldPassByReference :: Representation -> Bool +shouldPassByReference repr = + repr.pointers * wordBytes + repr.nonPointerBytes > 2 * wordBytes diff --git a/src/Low/Syntax.hs b/src/Low/Syntax.hs index 448de27..024d304 100644 --- a/src/Low/Syntax.hs +++ b/src/Low/Syntax.hs @@ -26,13 +26,13 @@ data Term v | Copy !(Operand v) !(Operand v) !(Operand v) | Store !(Operand v) !(Operand v) !Representation | Load !(Operand v) !Representation - | Empty deriving (Eq, Show, Generic, Hashable) data Operand v = Var !(Index v) | Global !Name.Lifted | Literal !Literal + | Representation !Representation | Tag !Name.QualifiedConstructor deriving (Eq, Show, Generic, Hashable) @@ -54,6 +54,6 @@ data Definition deriving (Eq, Show, Generic, Hashable) data Signature - = ConstantSignature !(PassBy ()) + = ConstantSignature !Representation | FunctionSignature [(PassBy ())] !(PassBy ()) deriving (Eq, Show, Generic, Hashable) diff --git a/src/Lower.hs b/src/Lower.hs index 3ffd8db..7a33a4a 100644 --- a/src/Lower.hs +++ b/src/Lower.hs @@ -5,16 +5,21 @@ module Lower where +import qualified Builtin import qualified ClosureConverted.Domain as CC.Domain -import qualified ClosureConverted.Readback as CC.Readback +import qualified ClosureConverted.Evaluation as Evaluation +import qualified ClosureConverted.Readback as Readback +import qualified ClosureConverted.Representation2 as CC.Representation import qualified ClosureConverted.Syntax as CC.Syntax import Core.Bindings (Bindings) import Data.Tsil (Tsil) import qualified Data.Tsil as Tsil +import qualified Environment import Index (Index) import qualified Index.Map import qualified Index.Map as Index (Map) import Literal (Literal) +import qualified Literal import Low.PassBy (PassBy) import qualified Low.PassBy as PassBy import Low.Representation (Representation) @@ -24,6 +29,8 @@ import Monad import Name (Name) import qualified Name import Protolude hiding (repr) +import qualified Query +import Rock.Core import Var (Var) data Value @@ -40,13 +47,13 @@ data Value | Copy !Operand !Operand !Operand | Store !Operand !Operand !Representation | Load !Operand !Representation - | Empty deriving (Show) data Operand = Var !Var | Global !Name.Lifted | Literal !Literal + | Representation !Representation | Tag !Name.QualifiedConstructor deriving (Show) @@ -55,7 +62,7 @@ data Branch | LiteralBranch !Literal !Value deriving (Show) -data Represented a = Represented !a !(PassBy CC.Domain.Value) +data PassedBy a = PassedBy !a !(PassBy (Collect Operand)) deriving (Functor) data Collectible @@ -84,70 +91,114 @@ collect m = do storeOperand :: CC.Domain.Environment v - -> Index.Map v (Represented Var) - -> Represented Operand - -> Represented Operand + -> Index.Map v (PassedBy Operand) + -> Operand + -> PassedBy Operand -> M Value -storeOperand env indices (Represented dst dstPassBy) (Represented src srcPassBy) = - case (dstPassBy, srcPassBy) of - (PassBy.Value dstRepr, PassBy.Value srcRepr) -> do - when (dstRepr /= srcRepr) $ panic "repr mismatch" +storeOperand env indices dst (PassedBy src srcPassBy) = + case srcPassBy of + PassBy.Value srcRepr -> pure $ Store dst src srcRepr - (PassBy.Reference _dstReprValue, PassBy.Reference srcReprValue) -> do - srcReprTerm <- CC.Readback.readback env srcReprValue + PassBy.Reference srcRepr -> collect do - srcRepr <- generateTerm env indices srcReprTerm - srcReprVar <- forceValue env indices Representation.type_ srcRepr - pure $ Copy dst src $ Var srcReprVar + srcReprOperand <- srcRepr + pure $ Copy dst src 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 - :: CC.Domain.Environment v - -> Index.Map v (Represented Var) - -> Representation - -> Represented Operand - -> Collect Var -forceValue env indices dstRepr (Represented var srcRepr) = - _ + :: Representation + -> PassedBy Operand + -> Collect Operand +forceValue dstRepr (PassedBy src srcPassBy) = + case srcPassBy of + PassBy.Value srcRepr -> do + when (dstRepr /= srcRepr) $ panic "repr mismatch" + pure src + PassBy.Reference _srcReprValue -> do + loaded <- lift freshVar + let_ "loaded" loaded $ Load src dstRepr + pure $ Var loaded + +forceReference :: PassedBy Operand -> Collect Operand +forceReference (PassedBy src srcPassBy) = + case srcPassBy of + PassBy.Reference _ -> + pure src + PassBy.Value srcRepr -> do + allocated <- lift freshVar + let_ "allocated" allocated $ StackAllocate $ Representation srcRepr + seq_ $ Copy (Var allocated) src $ Representation srcRepr + pure $ Var allocated storeTerm :: CC.Domain.Environment v - -> Index.Map v (Represented Var) - -> Represented Operand + -> Index.Map v (PassedBy Operand) + -> Operand -> CC.Syntax.Term v -> M Value storeTerm env indices dst = \case CC.Syntax.Var index -> do let src = Index.Map.index indices index - storeOperand env indices dst (Var <$> src) - CC.Syntax.Global global -> _ + storeOperand env indices dst src + CC.Syntax.Global global -> do + signature <- fetch $ Query.LowSignature global + case signature of + Low.Syntax.ConstantSignature repr -> + pure $ Copy dst (Global global) $ Representation repr + _ -> panic "Global without constant signature" CC.Syntax.Con con typeParams args -> _ - CC.Syntax.Lit lit -> _ - CC.Syntax.Let name term type_ body -> _ - CC.Syntax.Function tele -> _ + CC.Syntax.Lit lit -> pure $ Store dst $ Literal lit + CC.Syntax.Let name term type_ body -> do + type' <- Evaluation.evaluate env type_ + (env', var) <- Environment.extend env + collect do + termOperand <- generateTerm env indices term type' + lift $ 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 -> _ - CC.Syntax.Pi name domain target -> _ - CC.Syntax.Closure global args -> _ - CC.Syntax.ApplyClosure fun args -> _ + CC.Syntax.Pi name domain target -> + storeOperand env indices dst $ + PassedBy (Representation Representation.pointer) PassBy.Value + CC.Syntax.Closure global args -> panic "TODO closure" + CC.Syntax.ApplyClosure fun args -> panic "TODO closure" CC.Syntax.Case scrutinee type_ branches maybeDefault -> _ generateTerm :: CC.Domain.Environment v - -> Index.Map v (Represented Var) + -> Index.Map v (PassedBy Operand) -> CC.Syntax.Term v - -> Collect (Represented Operand) -generateTerm env indices = \case - CC.Syntax.Var index -> do - let (var, passBy) = Index.Map.index indices index - pure (identity, Var var, passBy) - CC.Syntax.Global global -> _ + -> CC.Domain.Type + -> Collect (PassedBy Operand) +generateTerm env indices term type_ = case term of + CC.Syntax.Var index -> pure $ Index.Map.index indices index + CC.Syntax.Global global -> do + signature <- fetch $ Query.LowSignature global + case signature of + Low.Syntax.ConstantSignature repr -> + pure $ PassedBy (Global global) PassBy.Reference $ pure $ Representation repr + _ -> panic "Global without constant signature" CC.Syntax.Con con typeParams args -> _ - CC.Syntax.Lit lit -> _ - CC.Syntax.Let name term type_ body -> _ - CC.Syntax.Function tele -> _ + CC.Syntax.Lit lit@(Literal.Integer _) -> pure $ PassedBy (Literal lit) $ PassBy.Value Representation.int + 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' + generateTerm env' (indices Index.Map.:> termOperand) body + CC.Syntax.Function tele -> + pure $ PassedBy (Reresentation Representation.rawFunctionPointer) PassBy.Value CC.Syntax.Apply global args -> _ - CC.Syntax.Pi name domain target -> _ - CC.Syntax.Closure global args -> _ - CC.Syntax.ApplyClosure fun args -> _ + CC.Syntax.Pi name domain target -> + pure $ + PassedBy (Representation Representation.pointer) PassBy.Value + CC.Syntax.Closure global args -> panic "TODO closure" + CC.Syntax.ApplyClosure fun args -> panic "TODO closure" CC.Syntax.Case scrutinee type_ branches maybeDefault -> _ readback :: Index.Map v Var -> Value -> Low.Syntax.Term v @@ -181,13 +232,13 @@ readback env = \case (readbackOperand env size) Store dst value repr -> Low.Syntax.Store (readbackVar env dst) (readbackOperand env value) repr Load src repr -> Low.Syntax.Load (readbackVar env src) repr - Empty -> Low.Syntax.Empty readbackOperand :: Index.Map v Var -> Operand -> Low.Syntax.Operand v readbackOperand env = \case Var var -> Low.Syntax.Var $ readbackVar env var Global global -> Low.Syntax.Global global Literal lit -> Low.Syntax.Literal lit + Representation repr -> Low.Syntax.Representation repr Tag tag -> Low.Syntax.Tag tag readbackVar :: Index.Map v Var -> Var -> Index v diff --git a/src/Query.hs b/src/Query.hs index 1708ac0..02582fa 100644 --- a/src/Query.hs +++ b/src/Query.hs @@ -34,6 +34,7 @@ import qualified Elaboration.Meta import Extra import qualified FileSystem import qualified LambdaLifted.Syntax as LambdaLifted +import qualified Low.Syntax import qualified Module import Name (Name) import qualified Name @@ -80,6 +81,7 @@ data Query a where ClosureConvertedType :: Name.Lifted -> Query (ClosureConverted.Type Void) ClosureConvertedConstructorType :: Name.QualifiedConstructor -> Query (Telescope Name ClosureConverted.Type ClosureConverted.Type Void) ClosureConvertedSignature :: Name.Lifted -> Query Representation.Signature + LowSignature :: Name.Lifted -> Query Low.Syntax.Signature ConstructorRepresentations :: Name.Qualified -> Query (Boxity, Maybe (HashMap Name.Constructor Int)) ConstructorRepresentation :: Name.QualifiedConstructor -> Query (Boxity, Maybe Int) Assembly :: Name.Lifted -> Query (Maybe Assembly.Definition) @@ -141,13 +143,14 @@ instance Hashable (Query a) where ClosureConvertedType a -> h 27 a ClosureConvertedConstructorType a -> h 28 a ClosureConvertedSignature a -> h 29 a - ConstructorRepresentations a -> h 30 a - ConstructorRepresentation a -> h 31 a - Assembly a -> h 32 a - HeapAllocates a -> h 33 a - AssemblyModule a -> h 34 a - LLVMModule a -> h 35 a - LLVMModuleInitModule -> h 36 () + LowSignature a -> h 30 a + ConstructorRepresentations a -> h 31 a + ConstructorRepresentation a -> h 32 a + Assembly a -> h 33 a + HeapAllocates a -> h 34 a + AssemblyModule a -> h 35 a + LLVMModule a -> h 36 a + LLVMModuleInitModule -> h 37 () where {-# INLINE h #-} h :: (Hashable b) => Int -> b -> Int diff --git a/src/Rules.hs b/src/Rules.hs index 72c544e..e20fe68 100644 --- a/src/Rules.hs +++ b/src/Rules.hs @@ -19,6 +19,7 @@ import qualified Builtin import qualified ClosureConversion import qualified ClosureConverted.Context import qualified ClosureConverted.Representation +import qualified ClosureConverted.Representation2 import qualified ClosureConverted.Syntax import qualified ClosureConverted.TypeOf as ClosureConverted import qualified ClosureConvertedToAssembly @@ -454,6 +455,10 @@ rules sourceDirectories files readFile_ (Writer (Writer query)) = noError do definition <- fetch $ ClosureConverted name runM $ ClosureConverted.Representation.signature definition + LowSignature name -> + noError do + definition <- fetch $ ClosureConverted name + runM $ ClosureConverted.Representation2.signature definition ConstructorRepresentations dataTypeName -> noError $ ClosureConverted.Representation.constructorRepresentations dataTypeName ConstructorRepresentation (Name.QualifiedConstructor dataTypeName constr) ->