diff --git a/src/Low/PassBy.hs b/src/Low/PassBy.hs index d1dd445..904bae1 100644 --- a/src/Low/PassBy.hs +++ b/src/Low/PassBy.hs @@ -1,7 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + module Low.PassBy where +import Protolude import Representation (Representation) data PassBy = Value !Representation | Reference + deriving (Eq, Show, Generic, Hashable) diff --git a/src/Low/Representation.hs b/src/Low/Representation.hs index 04d21fc..e911aa3 100644 --- a/src/Low/Representation.hs +++ b/src/Low/Representation.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + module Low.Representation where +import Protolude + data Representation = Representation { pointers :: !Int , nonPointerBytes :: !Int } + deriving (Eq, Show, Generic, Hashable) diff --git a/src/Low/Syntax.hs b/src/Low/Syntax.hs index 4a02a10..7f51eb5 100644 --- a/src/Low/Syntax.hs +++ b/src/Low/Syntax.hs @@ -1,26 +1,35 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + module Low.Syntax where +import Core.Bindings (Bindings) import Index +import Literal (Literal) +import Low.PassBy (PassBy) +import Low.Representation (Representation) +import qualified Name +import Protolude data Term v = Operand !(Operand v) | Global !Name.Qualified | Let !Bindings !(Term v) !(Scope Term v) - | Case (Index v) [Branch v] (Maybe (Term v)) + | Case !(Index v) [Branch v] (Maybe (Term v)) | Call !Name.Qualified [Operand v] | StackAllocate !(Operand v) | HeapAllocate !Name.QualifiedConstructor !(Operand v) - | Dereference !(Operand v) + | Dereference !(Index v) | PointerTag !(Index v) - | Offset (Operand v) (Index v) - | Copy (Index v) (Index v) (Operand v) - | Store (Index v) (Operand v) !Representation - | Load (Index v) !Representation + | Offset !(Operand v) !(Index v) + | Copy !(Index v) !(Index v) !(Operand v) + | Store !(Index v) !(Operand v) !Representation + | Load !(Index v) !Representation | Empty deriving (Eq, Show, Generic, Hashable) data Operand v - = Index v + = Var !(Index v) | Literal !Literal | Tag !Name.QualifiedConstructor deriving (Eq, Show, Generic, Hashable) @@ -31,8 +40,8 @@ data Branch v deriving (Eq, Show, Generic, Hashable) data Function v - = Empty !(Term v) - | Extend !Bindings !(Scope Function v) + = Body !(Term v) + | Parameter !Bindings !(Scope Function v) deriving (Eq, Show, Generic, Hashable) type Type = Term diff --git a/src/Lower.hs b/src/Lower.hs index e8df721..0b862a9 100644 --- a/src/Lower.hs +++ b/src/Lower.hs @@ -1,5 +1,96 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + module Lower where -import qualified Core.Syntax as Core +import Core.Bindings (Bindings) +import qualified Core.Domain +import qualified Core.Syntax +import Index (Index) +import qualified Index.Map +import qualified Index.Map as Index (Map) +import Literal (Literal) +import Low.PassBy (PassBy) +import Low.Representation (Representation) +import qualified Low.Syntax +import Monad +import qualified Name +import Protolude +import Var (Var) + +data Value + = Operand !Operand + | Global !Name.Qualified + | Let !Bindings !Value !Var !Value + | Case !Var [Branch] (Maybe Value) + | Call !Name.Qualified [Operand] + | StackAllocate !Operand + | HeapAllocate !Name.QualifiedConstructor !Operand + | Dereference !Var + | PointerTag !Var + | Offset !Operand !Var + | Copy !Var !Var !Operand + | Store !Var !Operand !Representation + | Load !Var !Representation + | Empty + deriving (Show) + +data Operand + = Var !Var + | Literal !Literal + | Tag !Name.QualifiedConstructor + deriving (Show) + +data Branch + = ConstructorBranch !Name.QualifiedConstructor !Value + | LiteralBranch !Literal !Value + deriving (Show) + +lower :: Core.Domain.Environment v -> Core.Syntax.Term v -> M Value +lower = undefined + +readback :: Index.Map v Var -> Value -> Low.Syntax.Term v +readback env = \case + Operand operand -> Low.Syntax.Operand $ readbackOperand env operand + Global global -> Low.Syntax.Global global + Let bindings value var value' -> + Low.Syntax.Let + bindings + (readback env value) + (readback (env Index.Map.:> var) value') + Case var branches maybeDefaultBranch -> + Low.Syntax.Case + (readbackVar env var) + (readbackBranch env <$> branches) + (readback env <$> maybeDefaultBranch) + Call function arguments -> Low.Syntax.Call function $ readbackOperand env <$> arguments + StackAllocate repr -> Low.Syntax.StackAllocate $ readbackOperand env repr + HeapAllocate con repr -> Low.Syntax.HeapAllocate con $ readbackOperand env repr + Dereference var -> Low.Syntax.Dereference $ readbackVar env var + PointerTag var -> Low.Syntax.PointerTag $ readbackVar env var + Offset offset var -> + Low.Syntax.Offset + (readbackOperand env offset) + (readbackVar env var) + Copy dst src size -> + Low.Syntax.Copy + (readbackVar env dst) + (readbackVar env src) + (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 + +readbackVar :: Index.Map v Var -> Var -> Index v +readbackVar env var = + fromMaybe (panic "Lower.readbackVar") $ + Index.Map.elemIndex var env -lower :: +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