wip

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)

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)

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

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