diff --git a/src/Data/Heap.hs b/src/Data/Heap.hs index 2fa28de..878cab6 100644 --- a/src/Data/Heap.hs +++ b/src/Data/Heap.hs @@ -27,6 +27,7 @@ import Debug.Trace import Data.Map.Strict qualified as M import Data.List (intersect) import GHC.Stack (HasCallStack) +import Control.Lens ---------------------------------------------------------------------------------- data Heap a = Heap [Addr] (Map Addr a) @@ -34,6 +35,21 @@ data Heap a = Heap [Addr] (Map Addr a) type Addr = Int +type instance Index (Heap a) = Addr +type instance IxValue (Heap a) = a + +instance Ixed (Heap a) where + ix a k (Heap as m) = Heap as <$> M.alterF k' a m where + k' (Just v) = Just <$> k v + k' Nothing = pure Nothing + +instance At (Heap a) where + at ma k (Heap as m) = Heap as <$> M.alterF k ma m + +instance FoldableWithIndex Addr Heap where + ifoldr fi z (Heap _ m) = ifoldr fi z m + ifoldMap iam (Heap _ m) = ifoldMap iam m + instance Semigroup (Heap a) where Heap ua ma <> Heap ub mb = Heap u m where @@ -54,7 +70,7 @@ instance Foldable Heap where length (Heap _ m) = M.size m instance Traversable Heap where - traverse t (Heap u m) = Heap u <$> (traverse t m) + traverse t (Heap u m) = Heap u <$> traverse t m ---------------------------------------------------------------------------------- diff --git a/src/GM.hs b/src/GM.hs index 84da355..7e272f5 100644 --- a/src/GM.hs +++ b/src/GM.hs @@ -32,6 +32,11 @@ import Text.PrettyPrint hiding ((<>)) import Text.PrettyPrint.HughesPJ (maybeParens) import Data.Foldable (traverse_) import System.IO (Handle, hPutStrLn) +-- TODO: an actual output system +-- TODO: an actual output system +-- TODO: an actual output system +-- TODO: an actual output system +import System.IO.Unsafe (unsafePerformIO) import Data.String (IsString) import Data.Heap import Debug.Trace @@ -40,6 +45,9 @@ import Core2Core import Core ---------------------------------------------------------------------------------- +tag_Unit_unit :: Int +tag_Unit_unit = 0 + tag_Bool_True :: Int tag_Bool_True = 1 @@ -99,6 +107,7 @@ data Instr = Unwind | Pack Tag Int -- Pack Tag Arity | CaseJump [(Tag, Code)] | Split Int + | Print | Halt deriving (Show, Eq) @@ -222,9 +231,33 @@ step st = case head (st ^. gmCode) of Split n -> splitI n Pack t n -> packI t n CaseJump as -> caseJumpI as + Print -> printI Halt -> haltI where + printI :: GmState + printI = case hLookupUnsafe a h of + NNum n -> (evilTempPrinter `seq` st) + & gmCode .~ i + & gmStack .~ s + where + -- TODO: an actual output system + -- TODO: an actual output system + -- TODO: an actual output system + -- TODO: an actual output system + evilTempPrinter = unsafePerformIO (print n) + NConstr _ as -> st + & gmCode .~ i' ++ i + & gmStack .~ s' + where + i' = mconcat $ replicate n [Eval,Print] + n = length as + s' = as ++ s + where + h = st ^. gmHeap + (a:s) = st ^. gmStack + Print : i = st ^. gmCode + -- nuke the state haltI :: GmState haltI = error "halt#" @@ -605,6 +638,8 @@ compiledPrims = , binop "/#" Div , binop "==#" Equals , binop "<#" Lesser + , ("print#", 1, [ Push 0, Eval, Print, Pack tag_Unit_unit 0, Update 1, Pop 1 + , Unwind]) ] where unop k i = (k, 1, [Push 0, Eval, i, Update 1, Pop 1, Unwind])