wip

ollef · May 13, 2024 · fff10e1 · fff10e1
1 parent 38a66b9
commit fff10e1
Show file tree

Hide file tree

Showing 3 changed files with 95 additions and 44 deletions.
diff --git 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
@@ -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
@@ -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