From 7a88ebab03b70fc3ea1669d02240a8949bef4507 Mon Sep 17 00:00:00 2001 From: Nathaniel Wesley Filardo Date: Tue, 30 Oct 2012 02:32:19 -0400 Subject: [PATCH] First pass at K3 Stdlib from experiments --- dyna.cabal | 3 +- src/Dyna/BackendK3/Stdlib.hs | 316 +++++++++++++++++++++++++++++++++++ 2 files changed, 318 insertions(+), 1 deletion(-) create mode 100644 src/Dyna/BackendK3/Stdlib.hs diff --git a/dyna.cabal b/dyna.cabal index b2fd934..bf4ec7a 100644 --- a/dyna.cabal +++ b/dyna.cabal @@ -28,7 +28,8 @@ Library Exposed-Modules: Dyna.BackendK3.AST, Dyna.BackendK3.Automation, - Dyna.BackendK3.Render + Dyna.BackendK3.Render, + Dyna.BackendK3.Stdlib, Dyna.ParserHS.Parser, Dyna.NormalizeParse, Dyna.XXX.HList, diff --git a/src/Dyna/BackendK3/Stdlib.hs b/src/Dyna/BackendK3/Stdlib.hs new file mode 100644 index 0000000..fdb589d --- /dev/null +++ b/src/Dyna/BackendK3/Stdlib.hs @@ -0,0 +1,316 @@ +--------------------------------------------------------------------------- +-- | A standard library for the K3 backend. A collection of canned +-- routines. +-- +-- Unlike Dyna.BackendK3.Automation, this is intended specifically for the +-- purpose of implementing Dyna-on-K3. + +-- Header material {{{ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Dyna.BackendK3.Stdlib ( + -- * Generic term storage + -- ** Haskell type level + TermIx, ArgIx, FAIx, TXRef, IndTy, IndTyRow, IndTyRowSet, + + -- ** K3 type level + ttermix, targix, tfaix, txref, indty, + + -- ** K3 data representation + fatab, faixCtr, heap, + + -- ** K3 representation mathematics + foldMath, foldMathSum, foldMathProd, + + -- ** K3 heap utilities + allocTermixHelper, allocTermix, allocFaix, findFaix, initHeapRow, + + -- ** Metaprogramming term representation utilities + -- *** Data Injections + indterm, indint, indflt, indstr, + -- *** Slice Injections + sindterm, sindint, sindflt, sindstr, + -- *** Projectors + proterm, proint, proflt, prostr, + + -- ** Metaprogramming heap utilities + hproindr, hpropara, hproeval + +) where + +import Control.Monad.State +import Dyna.BackendK3.AST +import Dyna.BackendK3.Automation +import Dyna.XXX.HList +import Dyna.XXX.MonadUtils +import Dyna.XXX.THTuple + +------------------------------------------------------------------------}}} +-- Generic term storage, Haskell type level {{{ + +type TermIx = Int +type ArgIx = Int +type FAIx = Int +type TXRef = (FAIx, TermIx) +type IndTy = HList '[Maybe TXRef, Maybe Int, Maybe Float, Maybe String] +type IndTyRow = (Int, Int, IndTy) +type IndTyRowSet r = CTE r CSet IndTyRow + +------------------------------------------------------------------------}}} +-- Generic term storage, K3 type level {{{ +-- +-- The type-annotations here serve to make the Haskell toolchain's output +-- prettier; being type aliases, though, there is no semantic difference +-- between these and the inferred types. + +-- | TERM IndeX +ttermix :: (K3Ty r) => r TermIx +ttermix = tInt + +-- | ARGument IndeX +targix :: (K3Ty r) => r ArgIx +targix = tInt + +-- | Functor and Arity IndeX +tfaix :: (K3Ty r) => r FAIx +tfaix = tInt + +-- | Term crossreference +txref = tTuple2 $ (tfaix, ttermix) + +-- | A node in a recursive term structure +-- +-- This needs more base-cases. +indty :: K3Ty r => r IndTy +indty = tHL + ( tMaybe txref -- Term xref + :++ tMaybe tInt -- Base int + :++ tMaybe tFloat -- Base float + :++ tMaybe tString -- Base string + :++ HRN + ) + `tAnn` [AOneOfHL] + +------------------------------------------------------------------------}}} +-- Generic term storage, K3 data representation {{{ + +-- | For each pair of functor and arity, what is the name we've given? +-- +-- Used when we don't know static assignments +fatab = flip (Decl $ Var "fatab") DKColl $ + tColl CTSet (tTuple3 (tfaix, tString, tInt)) + `tAnn` [ AFunDep (FDDom,FDCod,FDCod) + , AFunDep (FDCod,FDDom,FDDom) + ] + +-- | A counter for dynamic allocation of faixes +faixCtr = mkdecl $ \r -> Decl (Var "faixCtr") (tRef tfaix `asRefR` r) DKRef + +-- | The place we store all our terms, partitioned globally by functor-arity +-- values. For each faix, we store +-- +-- * a counter for the next possibly-free termix, +-- +-- * a table of arguments +-- +-- * a table of parasitic functors (which should be thought of as Dyna's +-- version of newtypes: top-level f/1 which are eliminated from +-- evaluations at compile time.) +-- +-- * a table of evaluations (including parasitic evaluations) +heap = mkdecl $ \r -> flip (Decl $ Var "heap") DKColl $ + (tColl CTSet $ + tHL ( tfaix + :++ tRef ttermix `asRefR` r + + -- Indirection + :++ tRef ((tColl CTSet $ tTuple3 (ttermix, targix, indty)) + `tAnn` [AFunDep (FDDom,FDDom,FDCod)] + `asCollR` r) `asRefR` r + + -- Parasitism (used when we don't statically know the parasitic + -- storage "offset") + :++ tRef ((tColl CTSet $ tTuple2 (tString, tInt)) + `tAnn` [AFunDep (FDDom,FDCod)] + `asCollR` r) `asRefR` r + + -- Evaluation (including parasitism) + :++ tRef ((tColl CTSet $ tTuple3 (ttermix, tInt, indty)) + `tAnn` [AFunDep (FDDom,FDDom,FDCod)] + `asCollR` r) `asRefR` r + + :++ HRN + )) + `tAnn` [AFunDepHL (FDDom :++ FDCod :++ FDCod :++ FDCod :++ FDCod :++ HRN) + , AXrefF fatab + (autopv, PUnk, PUnk) + (\(x,_,_) -> x) + (PVar autoty:+PUnk:+PUnk:+PUnk:+PUnk:+HN) + (\(x:+_) -> x) + ] + `asCollR` r + +------------------------------------------------------------------------}}} +-- Generic term storage, term representation mathematics {{{ + +foldMath (s,fn :: forall a b . (BiNum a b) => r a -> r b -> r (BNTF a b)) + = Decl (Var $ "foldMath" ++ s) (tFun (tTuple2 (indty, indty)) indty) $ DKFunc $ + eLam (PVar indty, PVar indty) $ \(a,b) -> + localVar (pronum a) $ \aif -> + localVar (pronum b) $ \bif -> + eITE (aif `eEq` eTuple2 (cNothing, cNothing)) (indstr $ cString "Error") $ + eITE (bif `eEq` eTuple2 (cNothing, cNothing)) (indstr $ cString "Error") $ + eApp (eLam (PVar $ tMaybe tInt, PVar $ tMaybe tFloat) $ \(mai,maf) -> + caseMaybe tInt mai (eApp (eLam (PJust $ PVar tFloat) + $ \a -> commonB a indflt bif + ) maf) + $ \a -> commonB a indint bif + ) aif + where + commonB :: (K3 r, BiNum a Float, BNTF a Float ~ Float, BiNum a Int) + => r a + -> (r (BNTF a Int) -> r IndTy) + -> r (Maybe Int, Maybe Float) + -> r IndTy + commonB a f bif = + eApp (eLam (PVar $ tMaybe tInt, PVar $ tMaybe tFloat) $ \(mbi,mbf) -> + caseMaybe tInt mbi + (eApp (eLam (PJust $ PVar tFloat) $ \b -> indflt $ a `fn` b) mbf) + (\b -> f $ a `fn` b) + ) bif + + +foldMathSum = foldMath ("sum" , eAdd) +foldMathProd = foldMath ("prod", eMul) + +------------------------------------------------------------------------}}} +-- Generic term storage, metaprogramming term representation {{{ + +indterm :: K3 r => r TXRef -> r IndTy +indterm x = eHL (eJust x :++ cNothing :++ cNothing :++ cNothing :++ HRN) + +indint :: K3 r => r Int -> r IndTy +indint x = eHL (cNothing :++ eJust x :++ cNothing :++ cNothing :++ HRN) + +indflt :: K3 r => r Float -> r IndTy +indflt x = eHL (cNothing :++ cNothing :++ eJust x :++ cNothing :++ HRN) + +indstr :: K3 r => r String -> r IndTy +indstr x = eHL (cNothing :++ cNothing :++ cNothing :++ eJust x :++ HRN) + +sindterm :: (K3 r, PatDa w ~ PVar r TXRef) + => r TXRef + -> HList [PJust w, PVar r (Maybe Int), PVar r (Maybe Float), PVar r (Maybe String)] +sindterm x = (PJust (PVar x) :+ PVar cNothing :+ PVar cNothing :+ PVar cNothing :+ HN) + +sindint x = (PVar cNothing :+ PJust (PVar x) :+ PVar cNothing :+ PVar cNothing :+ HN) +sindflt x = (PVar cNothing :+ PVar cNothing :+ PJust (PVar x) :+ PVar cNothing :+ HN) +sindstr x = (PVar cNothing :+ PVar cNothing :+ PVar cNothing :+ PJust (PVar x) :+ HN) + +proterm (x :: r IndTy) = + flip eApp x $ eLam (PJust (PVar $ tTuple2 (tfaix,ttermix)) :+ PUnk :+ PUnk :+ PUnk :+ HN) + (\(i:+_:+_:+_:+HN) -> i) +proint (x :: r IndTy) = + flip eApp x $ eLam (PUnk :+ PJust (PVar tInt) :+ PUnk :+ PUnk :+ HN) + (\(_:+i:+_:+_:+HN) -> i) +proflt (x :: r IndTy) = + flip eApp x $ eLam (PUnk :+ PUnk :+ PJust (PVar tFloat) :+ PUnk :+ HN) + (\(_:+_:+i:+_:+HN) -> i) +prostr (x :: r IndTy) = + flip eApp x $ eLam (PUnk :+ PUnk :+ PUnk :+ PJust (PVar tString) :+ HN) + (\(_:+_:+_:+i:+HN) -> i) + +pronum (x :: r IndTy) = + flip eApp x $ eLam (PUnk :+ PVar (tMaybe tInt) :+ PVar (tMaybe tFloat) :+ PUnk :+ HN) + (\(_:+i:+j:+_:+HN) -> eTuple2 (i,j)) + +------------------------------------------------------------------------}}} +-- Generic term storage, heap utility functions {{{ + +-- | Set up a new faix on the heap +initHeapRow = Decl (Var "initHeapRow") (tFun tfaix tUnit) $ DKFunc $ + eLam autopv (\faix -> eInsert (declVar heap) + $ eHL $ faix + :++ eRef (cInt 0) + :++ eRef eEmpty + :++ eRef eEmpty + :++ eRef eEmpty + :++ HRN) + + + + +-- | Find us a free faix, starting at (deref faixCtr) +allocFaix = mkfdecl $ \_ s -> Decl (Var "allocFaix") (tFun tUnit tfaix) $ DKFunc $ + eLam PUnk $ \_ -> + eApp (eLam (PRef $ PVar tfaix) + (\fa -> eBlock [ eAssign cr (fa `eAdd` cInt 1) ] + $ eITE (eEmpty `eEq` eSlice (PVar fa,PUnk,PUnk) + (declVar fatab)) + (fa) + (eApp s cUnit))) + cr + where cr = declVar faixCtr + +findFaix = mkdecl $ \_ -> Decl (Var "findFaix") (tFun (tTuple2 (tString, tInt)) tfaix) $ DKFunc $ + eLam (autopv, autopv) $ \(f,n) -> localVar (search f n) (\sr -> emptyPeek sr (create f n) id) + where + search f n = eMap (eLam (PVar tfaix,PUnk,PUnk) (\(x,_,_) -> x)) + $ eSlice (PUnk, PVar f, PVar n) (declVar fatab) + create f n = localVar (eApp (declVar allocFaix) cUnit) + (\i -> eBlock [eInsert (declVar fatab) (eTuple3 (i,f,n))] i) + + +allocTermixHelper = mkfdecl $ \_ s -> + Decl (Var "allocTermixHelper") + (tFun (tTuple2 (tRef ttermix, tColl CTSet $ tTuple3 (ttermix, targix, indty))) + ttermix) + $ DKFunc $ + eLam (autopv,autopv) $ \(tr,ts) -> localVar (deref tr) + $ \ti -> eBlock [ eAssign tr (ti `eAdd` cInt 1) ] + $ eITE (eEmpty `eEq` eSlice (PVar ti, PUnk, PUnk) ts) + ti + (eApp s $ eTuple2 (tr,ts)) + +-- | Find us a free termix in a given faix +allocTermix = mkfdecl $ \_ s -> Decl (Var "allocTermix") (tFun tfaix ttermix) $ DKFunc $ + eLam autopv $ \fa -> + eApp (declVar allocTermixHelper) + (ePeek $ eMap (eLam (PUnk :+ PVar (tRef ttermix) :+ PVar autoty :+ PUnk :+ PUnk :+ HN) $ \(_:+r:+s:+_) -> eTuple2 (r,deref s)) + $ eSlice (PVar fa:+PUnk:+PUnk:+PUnk:+PUnk:+HN) (declVar heap)) + +------------------------------------------------------------------------}}} +-- Generic term storage, metaprogramming heap utility functions {{{ + +-- | Extract the indirection table for a given faix +hproindr faix = localVar $ ePeek $ + eMap (eLam (PUnk :+ PUnk :+ PVar autoty :+ PUnk :+ PUnk :+ HN) + (\(_:+_:+ts:+_:+_:+HN) -> ts)) + $ eSlice (PVar faix :+ PUnk :+ PUnk :+ PUnk :+ PUnk :+ HN) + (declVar heap) + +-- | Extract the parasitism table for a given faix +hpropara faix = localVar $ ePeek $ + eMap (eLam (PUnk :+ PUnk :+ PUnk :+ PVar autoty :+ PUnk :+ HN) + (\(_:+_:+_:+ps:+_:+HN) -> ps)) + $ eSlice (PVar faix :+ PUnk :+ PUnk :+ PUnk :+ PUnk :+ HN) + (declVar heap) + +-- | Extract the evaluation table for a given faix +hproeval faix = localVar $ ePeek $ + eMap (eLam (PUnk :+ PUnk :+ PUnk :+ PUnk :+ PVar autoty :+ HN) + (\(_:+_:+_:+_:+es:+HN) -> es)) + $ eSlice (PVar faix :+ PUnk :+ PUnk :+ PUnk :+ PUnk :+ HN) + (declVar heap) + + +------------------------------------------------------------------------}}} -- 2.50.1