gyehoek.cabal

@@ -14,9 +14,9 @@ build-type:    Simple
 -- extra-source-files:
 
 flag doctest
-     description: enable the doctest suite
+  description: enable the doctest suite
-     default: True
+  default:     True
-     manual: True
+  manual:      True
 
 common ghcstuffs-dev
   ghc-options:
@@ -60,7 +60,6 @@ library
     Gyehoek.CPS.Close
     Gyehoek.CPS.Convert
     Gyehoek.CPS.Eval
-    Gyehoek.CPS.Lower
     Gyehoek.CPS.Stackify
     Gyehoek.CPS.Syntax
     Gyehoek.Driver
@@ -77,6 +76,7 @@ library
     Gyehoek.Sexp.QQ
     Gyehoek.Sexp.Read
     Gyehoek.Sexp.Syntax
+    Gyehoek.Stack.Lower
     Gyehoek.Stack.Syntax
     Gyehoek.Stack.VM
     Gyehoek.Wasm
@@ -162,13 +162,15 @@ test-suite test
 
 -- https://github.com/martijnbastiaan/doctest-parallel/pull/66
 test-suite doctest
-  import:         ghcstuffs, ghcstuffs-dev
+  import:             ghcstuffs, ghcstuffs-dev
-  type:           exitcode-stdio-1.0
+  type:               exitcode-stdio-1.0
-  hs-source-dirs: test
+  hs-source-dirs:     test
-  build-depends: base
+  build-depends:      base
   default-extensions: CPP
-  main-is:        doctest.hs
+  main-is:            doctest.hs
+
   if flag(doctest)
-    build-depends: doctest-parallel  >=0.1
+    build-depends: doctest-parallel >=0.1
+
   else
-    cpp-options: "-DGYEHOEK_NO_DOCTEST"
+    cpp-options: -DGYEHOEK_NO_DOCTEST

src/Gyehoek/CPS/Lower.hs

@@ -1,325 +0,0 @@
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedLabels #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultilineStrings #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE ApplicativeDo #-}
-{-# LANGUAGE RecursiveDo #-}
-{- HLINT ignore "Use camelCase" -}
-module Gyehoek.CPS.Lower
-  (lower, lowerProgram) where
-
-import Gyehoek.CPS.Syntax
-import Data.Vector.Strict (Vector)
-import Control.Lens hiding (op)
-import Numeric.Natural
-import qualified Data.Vector.Strict as V
-import Gyehoek.Wasm qualified as Wasm
-import Gyehoek.Wasm hiding (Expr)
-import Control.Monad.Fix
-import Data.Text qualified as T
-import Data.Foldable (fold)
-import Gyehoek.Jalmot
-import Gyehoek.Sexp qualified as S
-import Gyehoek.Prelude
-
-
-data Env = MkEnv
-  { vars :: Vector Name
-  , kvars :: Vector Name
-  }
-  deriving (Show, Generic)
-
-type instance Index Env = Natural
-type instance IxValue Env = Name
-
-instance Ixed Env where
-  ix i = #vars . ix (fromIntegral i)
-
-
-
-tonat :: Integral a => a -> Natural
-tonat = fromIntegral
-
--- | @makeSmallFixnum@ emits an expression injecting the i32 on top
--- of the stack into the SCM unitype.
-makeSmallFixnum :: Wasm.Expr
-makeSmallFixnum = [expr|
-    (@gyehoek "construct small fixnum")
-    (i32.const 1)
-    i32.shl
-    ref.i31
-  |]
-
-getArgRegister :: Natural -> S.Datum
-getArgRegister n = S.Symbol [i|$arg#{n}|]
-
--- | Given an expression @e@ leaving a @ref eq@ atop the stack,
--- @pushArg rt n e@ sets the nth slot of the arg-passing array to the
--- result of @e@.
-pushArg :: Natural -> Wasm.Expr -> Wasm.Expr
-pushArg n e = [expr|
-    (@gyehoek begin pushArg)
-    ##{e}
-    (global.set #{reg})
-    (@gyehoek end pushArg)
-  |]
-  where reg = getArgRegister n
-
--- | Pop the nth arg from the arg-passing array onto the stack.
-popArg :: Natural -> Wasm.Expr
-popArg n = [expr|
-  (@gyehoek begin popArg)
-  (global.get #{reg})
-  ref.as_non_null
-  (@gyehoek end popArg)
-|]
-  where reg = getArgRegister n
-
-
-
-lowerVal :: (HasCallStack, GenMod :> es) => Env -> Val -> Eff es Wasm.Expr
-
-lowerVal g (ValImm imm) =
-  pure $ case imm of
-    ImmInt n -> [expr|
-      (i32.const #{n})
-      ##{makeSmallFixnum}
-    |]
-    ImmBool b -> [expr|
-      (i32.const #{b'})
-      ref.i31
-    |]
-      where b' :: Int = if b then 0b11 else 0b01
-    _ -> _
-
-lowerVal g (ValVar x) = do
-  pure [expr|(global.get #{l})|]
-  where
-    l = getArgRegister . fromIntegral . succ $ V.elemIndex x g.vars ^?! _Just
-
-lower' :: (GenMod :> es) => Env -> Exp -> Eff es Wasm.Expr
-
-lower' g (Halt [v]) = do
-  arg <- pushArg 0 <$> lowerVal g v
-  pure [expr|
-    ##{arg}
-    (return_call $halt (i32.const 1))
-  |]
-
-lower' g e@(ExpPrim p k) =
-  case p of
-    PrimAdd x y -> lowerBinOp "i32.add" g x y k
-    PrimMul x y -> lowerBinOp "i32.mul" g x y k
-
-lower' g (ExpIf c t f) = do
-  c' <- lowerVal g c
-  t' <- lower' g t
-  f' <- lower' g f
-  pure [expr|
-    ##{c'}
-    (call $gh-truthy?)
-    (if (then ##{t'})
-        (else ##{f'}))
-  |]
-
-lower' g (ExpLetRec [(r,AbsKappa kap)] e) = do
-  idx <- lowerKappa g kap
-  let g' = g & #kvars <>~ [r]
-  e' <- lower' g' e
-  pure [expr|
-    (@gyehoek "push cont" :idx #{idx})
-    (array.set $cont-stack-type
-               (global.get $cont-stack)
-               (global.get $cont-stack-top)
-               (ref.func #{idx}))
-    (global.set $cont-stack-top
-                (i32.add (global.get $cont-stack-top)
-                         (i32.const 1)))
-    ##{e'}
-  |]
-
-lower' g (ExpLetRec [(r,AbsLambda lam)] e) = do
-  idx <- lowerLambda g lam
-  let g' = g & #vars <>~ [r]
-  let n = succ $ length g.vars
-  e' <- lower' g' e
-  let reg = getArgRegister . fromIntegral $ n
-  pure [expr|
-    (i32.const 0)
-    (ref.func #{idx})
-    (struct.new $closure)
-    (global.set #{reg})
-    ##{e'}
-  |]
-
-lower' g e@(ExpApply f xs ktail) = do
-  let nargs = length xs
-  f' <- lowerVal g f
-  let l = succ $ V.elemIndex ktail g.kvars ^?! _Just
-  args <- fold <$>
-    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
-  pure [expr|
-    (@gyehoek "load args")
-    ##{args}
-    (i32.const 1)
-    ##{f'}
-    (ref.cast (ref $closure))
-    (struct.get $closure $code)
-    (return_call_ref $cont-type)
-    (@gyehoek todo
-     (f' ##{f'})
-     (ktail #{l}))
-  |]
-
-lower' g e@(ExpContinue k xs) = do
-  let nargs = length xs
-  args <- fold <$>
-    itraverse (\i -> fmap (pushArg $ tonat i) . lowerVal g) xs
-  pure [expr|
-    (@gyehoek "push args")
-    ##{args}
-    (@gyehoek "nargs")
-    (i32.const #{nargs})
-    (@gyehoek "pop cont stack")
-    (global.get $cont-stack-top)
-    (i32.const #{l})
-    i32.sub
-    (global.set $cont-stack-top)
-    (global.get $cont-stack)
-    (global.get $cont-stack-top)
-    (array.get $cont-stack-type)
-    ref.as_non_null
-    (return_call_ref $cont-type)
-  |]
-  where
-    l = succ $ V.elemIndex k g.kvars ^?! _Just
-
-lower' g e = error . S.encodeOrShow' S.datumIso $ e
-
-lowerKappa :: GenMod :> es => Env -> Kappa -> Eff es Idx
-lowerKappa g e@(MkKappa xs m) = do
-  let g' = g & #vars <>~ V.fromList xs
-  m' <- lower' g' m
-  idx <- Wasm.defineFunction [wat|
-    (func (param i32)
-      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{m'})
-  |]
-  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
-  pure idx
-
-lowerLambda :: GenMod :> es => Env -> Lambda -> Eff es Idx
-lowerLambda g e@(MkLambda xs ktail m) = do
-  let g' = g & #vars .~ V.fromList xs
-             & #kvars <>~ [ktail]
-  m' <- lower' g' m
-  idx <- Wasm.defineFunction [wat|
-    (func (param i32)
-      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{m'})
-  |]
-  Wasm.emit [wats|(elem declare funcref (ref.func #{idx}))|]
-  pure idx
-
-lowerBinOp
-  :: (GenMod :> es)
-  => Text -> Env -> Val -> Val -> Kappa -> Eff es Wasm.Expr
-lowerBinOp op g x y (MkKappa [r] e) = do
-  let op' = S.Symbol op
-  let g' = g & #vars <>~ [r]
-  let n = succ $ length (g ^. #vars)
-  let reg = getArgRegister . fromIntegral $ n
-  x' <- lowerVal g x
-  y' <- lowerVal g y
-  e' <- lower' g' e
-  pure [expr|
-    ##{x'}
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    ##{y'}
-    (i31.get_s (ref.cast (ref i31)))
-    (i32.const 1)
-    i32.shr_u
-    #{op'}
-    ##{makeSmallFixnum}
-    (global.set #{reg})
-    ##{e'}
-  |]
-
-
-
-emitRuntime :: GenMod :> es => Eff es ()
-emitRuntime = mfix \runtime -> do
-  Wasm.defineFunctions [wats|
-    (import "gyehoek" "write" (func $gh-write (param (ref eq))))
-    (import "gyehoek" "truthy?" (func $gh-truthy? (param (ref eq))
-                                  (result i32)))
-  |]
-  -- cont stack
-  Wasm.defineTypes [wats|
-    (type $heap-object (sub (struct (field $hash (mut i32)))))
-    (type $cont-type (func (param i32)))
-    (type $cont-stack-type (array (mut (ref null $cont-type))))
-    (type $closure (sub $heap-object
-                        (struct (field $hash (mut i32))
-                                (field $code (ref $cont-type)))))
-  |]
-  Wasm.defineGlobals [wats|
-    (global $cont-stack-top (mut i32) (i32.const 0))
-    (global $cont-stack (ref $cont-stack-type)
-            (array.new_default $cont-stack-type (i32.const 128)))
-  |]
-  -- arg registers
-  Wasm.defineGlobals [wats|
-    (global $arg0 (mut (ref null eq)) (ref.null eq))
-    (global $arg1 (mut (ref null eq)) (ref.null eq))
-    (global $arg2 (mut (ref null eq)) (ref.null eq))
-    (global $arg3 (mut (ref null eq)) (ref.null eq))
-    (global $arg4 (mut (ref null eq)) (ref.null eq))
-    (global $arg5 (mut (ref null eq)) (ref.null eq))
-    (global $arg6 (mut (ref null eq)) (ref.null eq))
-    (global $arg7 (mut (ref null eq)) (ref.null eq))
-    (global $arg8 (mut (ref null eq)) (ref.null eq))
-    (global $arg9 (mut (ref null eq)) (ref.null eq))
-    (global $arg10 (mut (ref null eq)) (ref.null eq))
-    (global $arg11 (mut (ref null eq)) (ref.null eq))
-    (global $arg12 (mut (ref null eq)) (ref.null eq))
-    (global $arg13 (mut (ref null eq)) (ref.null eq))
-    (global $arg14 (mut (ref null eq)) (ref.null eq))
-    (global $arg15 (mut (ref null eq)) (ref.null eq))
-  |]
-  -- other  things 😼
-  Wasm.defineGlobal [wat|
-    (global $result (mut (ref null eq))
-            (ref.null eq))
-  |]
-  -- procedures
-  let arg = popArg 0
-  Wasm.defineFunction [wat|
-    (func $halt (param i32)
-      ##{arg}
-      (global.set $result))
-  |]
-  pure ()
-
-lower :: Exp -> Eff es Text
-lower e = fmap Wasm.renderModule . Wasm.execGenMod $ do
-  runtime <- emitRuntime
-  let g = MkEnv mempty mempty
-  e' <- lower' g e
-  Wasm.defineFunction [wat|
-    (func $scm-entry (param i32)
-      (local (ref eq) (ref eq) (ref eq) (ref eq) (ref eq))
-      ##{e'})
-  |]
-  Wasm.defineFunction [wat|
-    (func (export "main")
-      (call $scm-entry (i32.const 0))
-      (call $gh-write (ref.as_non_null (global.get $result))))
-  |]
-  
-lowerProgram :: Program -> Eff es Text
-lowerProgram (MkProgram e) = lower e

src/Gyehoek/Sexp/Grammar.hs

@@ -150,14 +150,3 @@ instance DatumIso a => DataIso (V.Vector a) where
 
 instance (DatumIso a, DatumIso b) => DatumIso (a, b) where
   datumIso = with \tup2 -> list (el datumIso >>> el datumIso) >>> tup2
-
-data Example = MkExample (List Int) Text
-  deriving (Generic, Show)
-
-instance DataIso Example where
-  dataIso = with \g ->
-    flipped snoced
-    >>> onHead (traversed $ sealed int)
-    >>> onTail (onHead $ sealed symbol)
-    >>> swap
-    >>> g

src/Gyehoek/Stack/Lower.hs

@@ -0,0 +1,29 @@
+module Gyehoek.Stack.Lower
+  ( lowerProgram
+  ) where
+
+import Gyehoek.Stack.Syntax
+import Gyehoek.Wasm qualified as Wasm
+import Gyehoek.Prelude
+import Gyehoek.Wasm (wat, watM)
+
+
+lowerRoutine :: Routine -> Wasm.Function
+lowerRoutine rt = _
+
+lowerBlock :: Block -> Wasm.Expr
+lowerBlock = _
+
+lowerInstr :: Instr -> Wasm.Expr
+lowerInstr = \case
+  PopCont ktail -> [wat|
+    
+  |]
+
+lowerProgram :: Program -> Eff es Wasm.Module
+lowerProgram p = pure [watM|
+  (module
+    ##{rs})
+|]
+  where
+    rs = p ^.. #routines . each . to lowerRoutine

src/Gyehoek/Wasm.hs

@@ -6,182 +6,41 @@ module Gyehoek.Wasm
   (
     -- * syntax
     Module
-  , Idx
+  , Program
+  , Function
   , Expr
     -- ** quasiquoters
-  , expr
+  , watM
-  , S.sx
-  , S.sxs
-  -- * GenMod effect
-  , GenMod
-  , runGenMod
-  , execGenMod
-  , defineFunction
-  , defineType
-  , defineGlobal
-  , emit
-  , renderModule
   , wat
-  , wats
-  , defineFunctions
-  , defineTypes
-  , defineGlobals
   )
   where
 
 import Data.List (List)
 import GHC.Generics (Generic)
-import Data.Text (Text)
-import Effectful
-import Numeric.Natural (Natural)
-import Effectful.Dispatch.Dynamic
-import Effectful.State.Dynamic
-import Control.Lens
-import Data.Vector.Strict (Vector)
-import qualified Data.Vector.Strict as V
-import GHC.IsList (IsList(..))
 import Language.Haskell.TH.Quote (QuasiQuoter)
-import Data.Data (Data)
 import Gyehoek.Sexp qualified as S
-import Gyehoek.Sexp (Datum, sx, (>>>))
+import Gyehoek.Sexp (Datum, (>>>))
-import Data.Foldable (traverse_)
+import Data.Data (Data)
-import Data.Coerce (coerce)
 
 
-newtype Module = MkModule { inner :: Vector Datum }
+type Program = Module
-  deriving (Show, Generic)
+type Function = Datum
+type Expr = List Datum
+
+newtype Module = MkModule { inner :: List Datum }
+  deriving (Show, Generic, Data)
   deriving newtype (Semigroup, Monoid)
 
-newtype Expr = MkExpr { inner :: Vector Instr }
+instance S.DatumIso Module where
-  deriving (Show, Generic, Data, Eq)
+  datumIso = S.with \g ->
-  deriving newtype (Semigroup, Monoid)
+    S.list (S.el (S.sym "module") >>> S.rest S.datumIso)
-
+    >>> g
-instance IsList Expr where
-  type Item Expr = Instr
-  fromList = MkExpr . V.fromList
-  toList = V.toList . view #inner
-
-newtype Instr = MkInstr { inner :: Datum }
-  deriving (Show, Generic, Data, Eq)
-
-newtype Idx = MkIdx { inner :: Natural }
-  deriving (Generic, Data)
-  deriving newtype (Show)
-
-
--- GenMod
-
--- | 'GenModState' is a 'Module' paired with the numbers of functions,
--- types, globals, etc. defined in the module.
-data GenModState = MkGenModState
-  { mod :: Module
-  , funcs :: Natural
-  , types :: Natural
-  , globals :: Natural
-  }
-  deriving (Show, Generic)
-
-instance Semigroup GenModState where
-  m1 <> m2 = MkGenModState
-    { mod = m1.mod <> m2.mod
-    , funcs = m1.funcs + m2.funcs
-    , types = m1.types + m2.types
-    , globals = m1.globals + m2.globals
-    }
-
-instance Monoid GenModState where
-  mempty = MkGenModState
-    { mod = mempty
-    , funcs = 0
-    , types = 0
-    , globals = 0
-    }
-
-data GenMod :: Effect where
-  DefineFunction :: Datum -> GenMod m Idx
-  DefineType :: Datum -> GenMod m Idx
-  DefineGlobal :: Datum -> GenMod m Idx
-  Emit :: Datum -> GenMod m ()
-
-type instance DispatchOf GenMod = Dynamic
-
-defineFunction :: GenMod :> es => Datum -> Eff es Idx
-defineFunction = send . DefineFunction
-
-defineFunctions :: GenMod :> es => List Datum -> Eff es (List Idx)
-defineFunctions = traverse (send . DefineFunction)
-
-defineType :: GenMod :> es => Datum -> Eff es Idx
-defineType = send . DefineType
-
-defineTypes :: GenMod :> es => List Datum -> Eff es (List Idx)
-defineTypes = traverse (send . DefineType)
-
-defineGlobal :: GenMod :> es => Datum -> Eff es Idx
-defineGlobal = send . DefineGlobal
-
-defineGlobals :: GenMod :> es => List Datum -> Eff es (List Idx)
-defineGlobals = traverse (send . DefineGlobal)
-
-emit :: GenMod :> es => List Datum -> Eff es ()
-emit = traverse_ (send . Emit)
-
-appendAndIncrement
-  :: State GenModState :> es
-  => LensLike' ((,) Natural) GenModState Natural
-  -> Datum
-  -> Eff es Idx
-appendAndIncrement l s =
-  state \st -> st
-    & #mod . #inner <>~ V.singleton s
-    & l <<%~ succ
-    & _1 %~ MkIdx
-
-runGenMod :: Eff (GenMod : es) a -> Eff es (a, Module)
-runGenMod =
-  let run = (mapped . _2 %~ view #mod) . runStateLocal (mempty @GenModState)
-  in reinterpret run \cases
-    _ (DefineFunction s) -> appendAndIncrement #funcs s
-    _ (DefineType s) -> appendAndIncrement #types s
-    _ (DefineGlobal s) -> appendAndIncrement #globals s
-    _ (Emit s) -> #mod . #inner <>= V.singleton s
-
-execGenMod :: Eff (GenMod : es) a -> Eff es Module
-execGenMod = fmap snd . runGenMod
-
-renderModule :: Module -> Text
-renderModule (MkModule ss) = S.encodeWith' S.datumIso [sx|
-  (module ##{ss})
-|]
-
-
--- DatumIso instances
-
-instance S.DatumIso Idx where
-  datumIso = S.with \idx ->
-    S.integer >>> S.partialOsi f g
-    >>> idx
-    where
-      f n | n < 0 = Left $ S.unexpected "negative"
-                        <> S.expected "natural"
-          | otherwise = Right $ fromIntegral n
-      g = fromIntegral
-
-instance S.DatumIso Instr where
-  datumIso = S.with S.id
-
-instance S.DataIso Expr where
-  dataIso = S.dataIso @(Vector Instr) >>> S.iso coerce coerce
 
 
 -- quasiquoters
 
-expr :: QuasiQuoter
-expr = S.makeSxs
-  [|| MkExpr . V.fromList . fmap (S.fromDatumUnsafe $ S.datumIso @Instr) ||]
-
 wat :: QuasiQuoter
-wat = S.makeSx [|| id ||]
+wat = S.makeSxs [|| S.fromDataUnsafe (S.dataIso @(List Datum)) ||]
 
-wats :: QuasiQuoter
+watM :: QuasiQuoter
-wats = S.makeSxs [|| id ||]
+watM = S.makeSx [|| S.fromDatumUnsafe (S.datumIso @Module) ||]