From 96082b7e45f3ce92c2ffd19cdc5e287cfc8ba1b7 Mon Sep 17 00:00:00 2001 From: Olle Fredriksson Date: Sat, 18 May 2024 00:40:25 +0200 Subject: [PATCH] wip --- src/Low/Pretty.hs | 288 +++++++++++++++++++--------------------------- src/Low/Syntax.hs | 2 +- src/Lower.hs | 24 +++- 3 files changed, 139 insertions(+), 175 deletions(-) diff --git a/src/Low/Pretty.hs b/src/Low/Pretty.hs index 7025075..9e9e033 100644 --- a/src/Low/Pretty.hs +++ b/src/Low/Pretty.hs @@ -2,33 +2,33 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} module Low.Pretty where -import qualified Boxity import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import Data.HashSet (HashSet) import qualified Data.HashSet as HashSet import qualified Data.Kind -import qualified Data.OrderedHashMap as OrderedHashMap import qualified Data.Sequence as Seq import qualified Data.Text.Unsafe as Text import Index +import Low.PassBy (PassBy) +import qualified Low.PassBy as PassBy +import Low.Representation (Representation) +import qualified Low.Representation as Representation import qualified Low.Syntax as Syntax import Name (Name (Name)) import qualified Name -import Plicity import Prettyprinter -import Protolude +import Protolude hiding (repr) import Query (Query) import qualified Query import qualified Query.Mapped as Mapped import Rock import qualified Scope -import Telescope (Telescope) -import qualified Telescope ------------------------------------------------------------------------------- -- Pretty-printing environments @@ -45,8 +45,7 @@ extend env (Name name) = go (Name.Surface name : [Name.Surface $ name <> show (i :: Int) | i <- [0 ..]]) where go (name' : names) - | name' `HashMap.member` usedNames env = - go names + | name' `HashMap.member` usedNames env = go names | otherwise = ( env { varNames = varNames env Seq.|> name' @@ -54,8 +53,7 @@ extend env (Name name) = } , name' ) - go [] = - panic "Pretty.extend" + go [] = panic "Pretty.extend" empty :: Environment Void empty = @@ -82,59 +80,68 @@ emptyM module_ = do ------------------------------------------------------------------------------- prettyTerm :: Int -> Environment v -> Syntax.Term v -> Doc ann -prettyTerm prec env term = - case term of - Syntax.Operand operand -> prettyOperand env operand - Syntax.Let lets -> - prettyParen (prec > letPrec) $ - "let" +prettyTerm prec env = \case + Syntax.Operand operand -> prettyOperand env operand + Syntax.Let passBy name term body -> + prettyParen (prec > letPrec) do + let (env', name') = extend env name + "let" + <+> prettyPassBy passBy + <+> pretty name' + <+> "=" + <+> prettyTerm 0 env term <> line <> "in" + <+> prettyTerm letPrec env' body + Syntax.Seq term1 term2 -> + prettyParen (prec > seqPrec) $ + prettyTerm (seqPrec + 1) env term1 + <> ";" + <> line + <> prettyTerm seqPrec env term2 + Syntax.Case scrutinee branches defaultBranch -> + prettyParen (prec > casePrec) $ + "case" + <+> prettyOperand env scrutinee + <+> "of" <> line - <> indent 2 (prettyLets env lets) - Syntax.Call function args -> - prettyParen (prec > appPrec) $ - prettyLiftedGlobal function env <> encloseSep lparen rparen comma [prettyOperand 0 env <$> args] - Syntax.Case scrutinee type_ branches defaultBranch -> - prettyParen (prec > casePrec) $ - "case" - <+> prettyTerm 0 env scrutinee - <+> "of" - <+> "->" - <+> prettyTerm 0 env type_ - <> line - <> indent - 2 - ( vcat $ - ( case branches of - Syntax.ConstructorBranches constructorTypeName constructorBranches -> - [ prettyConstr env (Name.QualifiedConstructor constructorTypeName constr) <+> prettyBranch env tele - | (constr, (_, tele)) <- OrderedHashMap.toList constructorBranches - ] - Syntax.LiteralBranches literalBranches -> - [ pretty lit <+> "->" <+> prettyTerm 0 env body - | (lit, (_, body)) <- OrderedHashMap.toList literalBranches - ] - ) - <> [ "_" - <+> "->" - <> line - <> indent 2 (prettyTerm casePrec env branch) - | Just branch <- [defaultBranch] - ] - ) - Syntax.Spanned _ term' -> - prettyTerm prec env term' - -prettyOperand :: Environment v -> Operand v -> Doc ann + <> indent + 2 + ( vcat $ + (prettyBranch env <$> branches) + <> [ "_" + <+> "->" + <> line + <> indent 2 (prettyTerm casePrec env branch) + | Just branch <- [defaultBranch] + ] + ) + Syntax.Call function args -> + prettyLiftedGlobal env function <> encloseSep lparen rparen comma (prettyOperand env <$> args) + Syntax.StackAllocate operand -> + "#stack_allocate" <> lparen <> prettyOperand env operand <> rparen + Syntax.HeapAllocate con operand -> + "#heap_allocate" <> encloseSep lparen rparen comma [prettyConstr env con, prettyOperand env operand] + Syntax.Dereference operand -> + "*" <> prettyOperand env operand + Syntax.PointerTag operand -> + "#pointer_tag" <> lparen <> prettyOperand env operand <> rparen + Syntax.Offset operand1 operand2 -> + prettyOperand env operand1 <+> "+" <+> prettyOperand env operand2 + Syntax.Copy dst src size -> + "#copy" <> encloseSep lparen rparen comma [prettyOperand env dst, prettyOperand env src, prettyOperand env size] + Syntax.Store dst src repr -> + "#store" <+> prettyRepresentation repr <> encloseSep lparen rparen comma [prettyOperand env dst, prettyOperand env src] + Syntax.Load src repr -> + "#load" <+> prettyRepresentation repr <> lparen <> prettyOperand env src <> rparen + +prettyOperand :: Environment v -> Syntax.Operand v -> Doc ann prettyOperand env = \case Syntax.Var (Index i) -> pretty $ Seq.index (varNames env) (Seq.length (varNames env) - i - 1) - Syntax.Global global -> - prettyGlobal env global - Syntax.Con constr -> - prettyConstr env constr - Syntax.Lit lit -> - pretty lit + Syntax.Global global -> prettyLiftedGlobal env global + Syntax.Literal lit -> pretty lit + Syntax.Representation repr -> prettyRepresentation repr + Syntax.Tag constr -> prettyConstr env constr prettyGlobal :: Environment v -> Name.Qualified -> Doc ann prettyGlobal env global = do @@ -144,12 +151,23 @@ prettyGlobal env global = do HashSet.toList $ HashMap.lookupDefault mempty global $ importedAliases env - case aliases of - [] -> - pretty global - alias : _ -> - pretty alias + [] -> pretty global + alias : _ -> pretty alias + +prettyLiftedGlobal :: Environment v -> Name.Lifted -> Doc ann +prettyLiftedGlobal env = \case + Name.Lifted global 0 -> prettyGlobal env global + Name.Lifted global n -> prettyGlobal env global <> "$" <> pretty n + +prettyPassBy :: PassBy () -> Doc ann +prettyPassBy = \case + PassBy.Value repr -> prettyRepresentation repr + PassBy.Reference () -> "ref" + +prettyRepresentation :: Representation -> Doc ann +prettyRepresentation repr = + "p" <> pretty repr.pointers <> "b" <> pretty repr.nonPointerBytes prettyConstr :: Environment v -> Name.QualifiedConstructor -> Doc ann prettyConstr env constr = do @@ -159,120 +177,50 @@ prettyConstr env constr = do HashSet.toList $ HashMap.lookupDefault mempty constr $ importedConstructorAliases env - case aliases of - [] -> - pretty constr - alias : _ -> - pretty alias + [] -> pretty constr + alias : _ -> pretty alias unambiguous :: Environment v -> Name.Surface -> Bool unambiguous env name = case HashMap.lookupDefault Nothing name $ usedNames env of - Nothing -> - True - Just (Scope.Name _) -> - True - Just (Scope.Constructors cs ds) -> - HashSet.size cs + HashSet.size ds == 1 - Just (Scope.Ambiguous _ _) -> - False + Nothing -> True + Just (Scope.Name _) -> True + Just (Scope.Constructors cs ds) -> HashSet.size cs + HashSet.size ds == 1 + Just (Scope.Ambiguous _ _) -> False prettyBranch :: Environment v - -> Telescope Name Syntax.Type Syntax.Term v - -> Doc ann -prettyBranch env tele = - case tele of - Telescope.Empty body -> - "->" <> line <> indent 2 (prettyTerm casePrec env body) - Telescope.Extend bindings type_ plicity tele' -> - let (env', name) = extendBindings env bindings - in Plicity.prettyAnnotation plicity - <> "(" - <> pretty name - <+> ":" - <+> prettyTerm 0 env type_ - <> ")" - <+> prettyBranch env' tele' - -------------------------------------------------------------------------------- - -prettyDefinition :: Environment Void -> Name.Qualified -> Syntax.Definition -> Doc ann -prettyDefinition env name def = - case def of - Syntax.TypeDeclaration type_ -> - prettyGlobal env name <+> ":" <+> prettyTerm 0 env type_ - Syntax.ConstantDefinition term -> - prettyGlobal env name <+> "=" <+> prettyTerm 0 env term - Syntax.DataDefinition boxity tele -> - Boxity.prettyAnnotation boxity "data" <+> prettyGlobal env name <+> prettyConstructorDefinitions env tele - -prettyConstructorDefinitions - :: Environment v - -> Telescope Binding Syntax.Type Syntax.ConstructorDefinitions v - -> Doc ann -prettyConstructorDefinitions env tele = - case tele of - Telescope.Empty (Syntax.ConstructorDefinitions constrs) -> - "where" - <> line - <> indent - 2 - ( vcat - [ pretty constr <+> ":" <+> prettyTerm 0 env type_ - | (constr, type_) <- OrderedHashMap.toList constrs - ] - ) - Telescope.Extend _ _ Implicit _ -> - "forall" <+> prettyConstructorDefinitionsImplicit env tele - Telescope.Extend binding type_ plicity tele' -> - let (env', name) = extendBinding env binding - in Plicity.prettyAnnotation plicity - <> "(" - <> pretty name - <+> ":" - <+> prettyTerm 0 env type_ - <> ")" - <+> prettyConstructorDefinitions env' tele' - -prettyConstructorDefinitionsImplicit - :: Environment v - -> Telescope Binding Syntax.Type Syntax.ConstructorDefinitions v + -> Syntax.Branch v -> Doc ann -prettyConstructorDefinitionsImplicit env tele = - case tele of - Telescope.Empty _ -> - prettyConstructorDefinitions env tele - Telescope.Extend binding type_ Implicit tele' -> - let (env', name) = extendBinding env binding - in lparen - <> pretty name - <+> ":" - <+> prettyTerm 0 env type_ - <> rparen - <> prettyConstructorDefinitionsImplicit env' tele' - Telescope.Extend {} -> - "." <+> prettyConstructorDefinitions env tele +prettyBranch env = \case + Syntax.ConstructorBranch constr body -> + prettyConstr env constr <+> "->" <> line <> indent 2 (prettyTerm casePrec env body) + Syntax.LiteralBranch lit body -> + pretty lit <+> "->" <> line <> indent 2 (prettyTerm casePrec env body) ------------------------------------------------------------------------------- -prettyPattern :: Int -> Environment v -> Pattern -> Doc ann -prettyPattern prec env pattern_ = - case pattern_ of - Pattern.Wildcard -> - "_" - Pattern.Con constr [] -> - prettyConstr env constr - Pattern.Con constr patterns -> - prettyParen (prec > appPrec) $ - hsep $ - prettyConstr env constr - : [ Plicity.prettyAnnotation plicity <> prettyPattern (appPrec + 1) env pattern' - | (plicity, pattern') <- patterns - ] - Pattern.Lit lit -> - pretty lit +prettyDefinition :: MonadFetch Query m => Environment Void -> Name.Lifted -> Syntax.Definition -> m (Doc ann) +prettyDefinition env name def = do + signature <- fetch $ Query.LowSignature name + pure case (def, signature) of + (Syntax.ConstantDefinition term, Syntax.ConstantSignature repr) -> + prettyLiftedGlobal env name <+> prettyRepresentation repr <+> "=" <+> prettyTerm 0 env term + (Syntax.ConstantDefinition _, _) -> panic "definition signature mismatch" + (Syntax.FunctionDefinition function, Syntax.FunctionSignature passArgsBy passReturnBy) -> + prettyLiftedGlobal env name <+> prettyPassBy passReturnBy <+> "=" <+> "\\" <+> prettyFunction env passArgsBy function + (Syntax.FunctionDefinition _, _) -> panic "definition signature mismatch" + +prettyFunction :: Environment v -> [PassBy ()] -> Syntax.Function v -> Doc ann +prettyFunction env passArgsBy function = case (passArgsBy, function) of + ([], Syntax.Body body) -> " ->" <> line <> prettyTerm 0 env body + ([], _) -> panic "function signature mismatch" + (passArgBy : passArgsBy', Syntax.Parameter name function') -> do + let (env', name') = extend env name + "(" <> prettyPassBy passArgBy + <+> pretty name' <> ")" <> prettyFunction env' passArgsBy' function' + (_ : _, _) -> panic "function signature mismatch" ------------------------------------------------------------------------------- @@ -280,9 +228,7 @@ prettyParen :: Bool -> Doc a -> Doc a prettyParen True doc = lparen <> doc <> rparen prettyParen False doc = doc -funPrec, appPrec, lamPrec, letPrec, casePrec :: Int -funPrec = 0 -appPrec = 10 -lamPrec = 0 -letPrec = 0 -casePrec = 0 +letPrec, seqPrec, casePrec :: Int +letPrec = 1 +seqPrec = 0 +casePrec = 1 diff --git a/src/Low/Syntax.hs b/src/Low/Syntax.hs index 1a6b714..b79e257 100644 --- a/src/Low/Syntax.hs +++ b/src/Low/Syntax.hs @@ -18,7 +18,7 @@ data Term v | Case !(Operand v) [Branch v] (Maybe (Term v)) | Call !Name.Lifted [Operand v] | StackAllocate !(Operand v) - | HeapAllocate !Int !(Operand v) + | HeapAllocate !Name.QualifiedConstructor !(Operand v) | Dereference !(Operand v) | PointerTag !(Operand v) | Offset !(Operand v) !(Operand v) diff --git a/src/Lower.hs b/src/Lower.hs index 6b5a25a..ccfb0e5 100644 --- a/src/Lower.hs +++ b/src/Lower.hs @@ -46,7 +46,7 @@ data Value | Case !Operand [Branch] (Maybe Value) | Call !Name.Lifted [Operand] | StackAllocate !Operand - | HeapAllocate !Int !Operand + | HeapAllocate !Name.QualifiedConstructor !Operand | Dereference !Operand | PointerTag !Operand | Offset !Operand !Operand @@ -121,6 +121,24 @@ addRepresentation :: Operand -> Operand -> Value addRepresentation x y = Call (Name.Lifted Builtin.AddRepresentationName 0) [x, y] +lowerDefinition :: Name.Lifted -> CC.Syntax.Definition -> M [Low.Syntax.Definition] +lowerDefinition name = \case + CC.Syntax.TypeDeclaration _ -> pure Nothing + CC.Syntax.ConstantDefinition term -> do + signature <- fetch $ Query.LowSignature name + case signature of + Low.Syntax.ConstantSignature repr -> _ + _ -> panic "Constant without constant signature" + CC.Syntax.FunctionDefinition tele -> do + signature <- fetch $ Query.LowSignature name + case signature of + Low.Syntax.FunctionSignature passArgsBy passReturnBy -> _ + _ -> panic "Function without function signature" + CC.Syntax.DataDefinition boxity tele -> do + _ + CC.Syntax.ParameterisedDataDefinition boxity tele -> do + _ + storeOperand :: Operand -> PassedBy Operand @@ -189,7 +207,7 @@ storeTerm context indices dst = \case sizeTerm <- lift $ boxedConstructorSize (CC.toEnvironment context) con typeParams args size <- generateTerm context indices sizeTerm $ CC.Domain.global $ Name.Lifted Builtin.TypeName 0 sizeValue <- forceValue Representation.type_ size - pointer <- letValue Representation.pointer "boxed_constr" $ HeapAllocate (fromMaybe 0 maybeTag) sizeValue + pointer <- letValue Representation.pointer "boxed_constr" $ HeapAllocate con sizeValue constrDst <- letReference "deref_constr" $ Dereference pointer let go argOffset arg = do argDst <- letValue Representation.type_ "constr_arg_dst" $ Offset constrDst argOffset @@ -332,7 +350,7 @@ generateTerm context indices term typeValue = case term of sizeTerm <- lift $ boxedConstructorSize (CC.toEnvironment context) con typeParams args size <- generateTerm context indices sizeTerm $ CC.Domain.global $ Name.Lifted Builtin.TypeName 0 sizeValue <- forceValue Representation.type_ size - pointer <- letValue Representation.pointer "boxed_constr" $ HeapAllocate (fromMaybe 0 maybeTag) sizeValue + pointer <- letValue Representation.pointer "boxed_constr" $ HeapAllocate con sizeValue constrDst <- letReference "deref_constr" $ Dereference pointer let go argOffset arg = do argDst <- letReference "constr_arg_dst" $ Offset constrDst argOffset