From dd851e8574c37cad729a3ba3b4e64a548bb4422e Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Tue, 26 May 2020 13:58:47 +0200 Subject: [PATCH] monomorph structgen --- structs/GenC.dcl | 76 +++++++++++ structs/GenC.icl | 349 +++++++++++++++++++++++++++++++++++++++++++++++ structs/scc.dcl | 13 ++ structs/scc.icl | 41 ++++++ structs/test.icl | 19 +++ 5 files changed, 498 insertions(+) create mode 100644 structs/GenC.dcl create mode 100644 structs/GenC.icl create mode 100644 structs/scc.dcl create mode 100644 structs/scc.icl create mode 100644 structs/test.icl diff --git a/structs/GenC.dcl b/structs/GenC.dcl new file mode 100644 index 0000000..b33d991 --- /dev/null +++ b/structs/GenC.dcl @@ -0,0 +1,76 @@ +definition module GenC + +import StdGeneric +from Data.Either import :: Either +from StdOverloaded import class zero + +/** + * Helper types for @ style types + */ +:: Box b a =: Box b +derive bimap Box +unBox (Box b) :== b +box b :== Box b +reBox x :== box (unBox x) + +/** + * Calculate whether a type has a potentially infinite size + */ +potInf :: Box Bool a | gPotInf{|*|} a +generic gPotInf a :: [String] -> Box Bool a +derive gPotInf Int, Bool, Char, Real, World, Dynamic, UNIT, CONS, FIELD, EITHER, PAIR, OBJECT of {gtd_name}, RECORD of {grd_name} + +/** + * Calculate the ctype representation of a type + */ +toStruct :: Box GTSState a | gToStruct{|*|} a +:: GTSResult +:: GTSState +instance zero GTSState +generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a) +derive gToStruct Int, Bool, Char, Real, UNIT, CONS, FIELD, EITHER, PAIR, OBJECT of {gtd_name,gtd_conses,gtd_num_conses}, RECORD of {grd_name,grd_fields} + +/** + * Given a GTSState, generate typedefinitions + */ +toCType :: GTSState -> [String] + +/** + * Given a GTSState, generate a parser + * @result Function signatures + * @result Function + */ +toCParser :: GTSState -> ([String], [String]) +/** + * Given a GTSState, generate a printer + * @result Function signatures + * @result Function + */ +toCPrinter :: GTSState -> ([String], [String]) + +/** + * Generate a serialized value for the given type + * @param value + * @param continuation list + * @result Bytes + */ +toCValue :: a [Char] -> [Char] | gToCValue{|*|} a +generic gToCValue a :: a [Char] -> [Char] +derive gToCValue Int, Bool, Char, UNIT, EITHER, PAIR, CONS of {gcd_index}, FIELD, RECORD, OBJECT + +/** + * Parse a value from the serializized value + * @param bytes + * @result Either an error or a value + */ +:: FromCValueError = CVEUnknownConstructor | CVEInputExhausted +fromCValue :: [Char] -> Either FromCValueError (a, [Char]) | gFromCValue{|*|} a +generic gFromCValue a :: ([Char] -> Either FromCValueError (a, [Char])) +derive gFromCValue Int, Bool, Char, UNIT, EITHER, PAIR, CONS of {gcd_index}, FIELD, RECORD, OBJECT + +/** + * @param type in a box with a filename + * @param .h file + * @param .c file + */ +toCFiles :: (Box String a) -> ([String], [String]) | gToStruct{|*|} a diff --git a/structs/GenC.icl b/structs/GenC.icl new file mode 100644 index 0000000..c566d23 --- /dev/null +++ b/structs/GenC.icl @@ -0,0 +1,349 @@ +implementation module GenC + +import StdEnv, StdGeneric, StdMaybe +import Data.Map => qualified updateAt +import Data.Func, Data.Tuple +import Data.Maybe +import Data.Either +import Text + +import scc + +derive bimap Box + +potInf :: Box Bool a | gPotInf{|*|} a +potInf = gPotInf{|*|} [] + +generic gPotInf a :: [String] -> Box Bool a +gPotInf{|Int|} _ = box False +gPotInf{|Bool|} _ = box False +gPotInf{|Char|} _ = box False +gPotInf{|Real|} _ = box False +gPotInf{|World|} _ = box False +gPotInf{|Dynamic|} _ = box False +gPotInf{|c|} _ = box False +gPotInf{|UNIT|} _ = box False +gPotInf{|CONS|} f s = reBox (f s) +gPotInf{|FIELD|} f s = reBox (f s) +gPotInf{|EITHER|} fl fr s = box (unBox (fl s) || unBox (fr s)) +gPotInf{|PAIR|} fl fr s = box (unBox (fl s) || unBox (fr s)) +gPotInf{|OBJECT of {gtd_name}|} f s + = if (isMember gtd_name s) (box True) (reBox (f [gtd_name:s])) +gPotInf{|RECORD of {grd_name}|} f s + = if (isMember grd_name s) (box True) (reBox (f [grd_name:s])) + +:: CType + = CTTypeDef String + | CTEnum [String] + | CTStruct [(String, [(String, Bool, String)])] + +:: GTSState = {dict :: Map String CType} +instance zero GTSState where zero = {dict=newMap} + +toStruct :: Box GTSState a | gToStruct{|*|} a +toStruct = snd $ gToStruct{|*|} zero +generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a) +:: GTSResult + = GTSType Bool String //ispointer and the name + | GTSUnit + | GTSEither [GTSResult] + | GTSPair [GTSResult] + | GTSError + +putst k v st = {st & dict=put k v st.dict} + +gToStruct{|Int|} st = (GTSType False "uint64_t", box st) +gToStruct{|Bool|} st = (GTSType False "bool", box st) +gToStruct{|Char|} st = (GTSType False "char", box st) +gToStruct{|Real|} st = (GTSType False "double", box st) +gToStruct{|UNIT|} st = (GTSUnit, box st) +gToStruct{|CONS|} f _ st = appSnd reBox $ f st +gToStruct{|FIELD|} f _ st = appSnd reBox $ f st +gToStruct{|EITHER|} fl _ fr _ st + # (l, Box st) = fl st + # (r, Box st) = fr st + = (case (l, r) of + (GTSEither l, GTSEither r) = GTSEither (l ++ r) + (a, GTSEither l) = GTSEither [a:l] + (l, r) = GTSEither [l, r] + , box st) +gToStruct{|PAIR|} fl _ fr _ st + # (l, Box st) = fl st + # (r, Box st) = fr st + = (case (l, r) of + (GTSPair l, GTSPair r) = GTSPair (l ++ r) + (a, GTSPair l) = GTSPair [a:l] + (l, r) = GTSPair [l, r] + , box st) +gToStruct{|OBJECT of {gtd_name,gtd_conses,gtd_num_conses}|} f i st + # (Box isPInf) = i [] + # ty = GTSType isPInf + = case get gtd_name st.dict of + Just _ = (GTSType isPInf gtd_name, box st) + Nothing + //Newtype + | gtd_num_conses == 0 + = case f st of + (GTSType pi n, Box st) = (GTSType pi gtd_name, box $ putst gtd_name (CTTypeDef n) st) + //If it is just an enumeration, Just the enum + | and [gcd.gcd_arity == 0\\gcd<-gtd_conses] + = (GTSType False gtd_name, box $ putst gtd_name (CTEnum [gcd.gcd_name\\gcd<-gtd_conses]) st) + //Constructors with data fields + # (n, Box st) = appFst mkty $ f $ putst gtd_name (CTTypeDef gtd_name) st + = + ( GTSType isPInf gtd_name + , box $ putst gtd_name (CTStruct (zip2 [gcd.gcd_name\\gcd<-gtd_conses] (map (toT o mkccons) n))) st + ) + where + mkty (GTSEither l) = l + mkty t = [t] + + mkccons (GTSType pi t) = [GTSType pi t] + mkccons (GTSPair t) = t + mkccons _ = [] + + toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons] +gToStruct{|RECORD of {grd_name,grd_fields}|} f i st + # (Box isPInf) = i [] + = case get grd_name st.dict of + Just n = (GTSType isPInf grd_name, box st) + Nothing + # (n, Box st) = f $ putst grd_name (CTTypeDef grd_name) st + = case n of + GTSPair l = + ( GTSType isPInf grd_name + , box $ putst grd_name (CTStruct [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st) + _ = (GTSError, box st) + +/** + * Given a GTSState, generate typedefinitions + */ +toCType :: GTSState -> [String] +toCType {dict=m} = foldr proc [] $ scc $ map (appSnd refs) $ toList m +where + refs (CTTypeDef s) = [s] + refs (CTEnum _) = [] + refs (CTStruct cs) = map fst3 (flatten (map snd cs)) + + proc [] c = c + proc [x] c = ctypedef x (find x m) c + proc xs c = foldr (prototype o fst) (foldr (uncurry ctypedef) c ts) ts + where + ts = [(x, find x m)\\x<-xs] + prototype x c = ["struct ", x, ";\n":c] + + ctypedef :: String CType [String] -> [String] + ctypedef name (CTTypeDef a) c = ["typedef ", a, " ", name, ";\n":c] + ctypedef name (CTEnum a) c = ["enum ", name, " {": enum a ["};\n":c]] + ctypedef name (CTStruct [(_, fs)]) c = + [ "struct ", name, " {\n" + : foldr (uncurry3 (field 1)) + ["};\n":c] fs + ] + ctypedef name (CTStruct cs) c = + [ "struct ", name, " {\n" + : ind 1 ["enum {" + : enum (map fst cs) + ["} cons;\n" + : ind 1 ["union {\n" + : foldr (uncurry struct) + (ind 1 ["} data;\n};\n":c]) + cs]]]] + + struct name [] c = c + struct name [(ty, pi, _)] c = field 2 ty pi name c + struct name fs c = ind 2 ["struct {\n" :foldr (uncurry3 (field 3)) (ind 2 ["} ", name, ";\n":c]) fs] + + field i ty pi name c + = ind i $ typeName ty m [if pi " *" " ", name, ";\n":c] + + enum [] c = c + enum [x] c = [x:c] + enum [x:xs] c = [x, ",": enum xs c] + +typeName ty m c = [case get ty m of + Just (CTStruct _) = "struct " + Just (CTEnum _) = "enum " + _ = "" + , ty:c] + +ind n c = [createArray n '\t':c] + +uncurry3 f (x,y,z) = f x y z + +/** + * Given a GTSState, generate a parser + * @result Function signature + * @result Function + */ +toCParser :: GTSState -> ([String], [String]) +toCParser {dict=m} = (funsigs, foldr funbody [] (toList m)) +where + funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m] + pfname n c = ["parse_", n:c] + pfcall n c = pfname n ["(get, alloc, err);":c] + funsig n c + = typeName n m [" ": pfname n ["(\n" + : ind 1 ["uint8_t (*get)(void),\n" + : ind 1 ["void *(*alloc)(size_t),\n" + : ind 1 ["void (*err)(const char *errmsg, ...))" + :c]]]]] + funbody (n, ty) c = funsig n + ["\n{\n" + :ind 1 $ typeName n m [" r;\n" + :funb ty $ ind 1 ["return r;\n}\n":c]]] + + funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a ["\n":c]] + funb (CTEnum a) c = ind 1 ["r = get()\n":c] + funb (CTStruct [(_, fs)]) c = foldr (sfield 1 "r") c fs + funb (CTStruct fs) c + = ind 1 ["switch(r.cons = get()) {\n" + :foldr field + ( ind 1 ["default:\n" + : ind 2 ["break;\n" + : ind 1 ["}\n":c]]]) fs] + where + field (n, []) c = c + field (n, fs) c = + ind 1 ["case ", n, ":\n" + : foldr (sfield 2 ("r.data."+++ n)) + (ind 2 ["break;\n":c]) fs] + + sfield i r (ty, ptr, f) c + = (\c->if ptr (ind i [r, ".", f, " = alloc(sizeof(":typeName ty m ["));\n":c]]) c) + $ ind i [if ptr "*" "", r, ".", f, " = ":pfcall ty ["\n":c]] + +/** + * Given a GTSState, generate a printer + * @result Function signature + * @result Function + */ +toCPrinter :: GTSState -> ([String], [String]) +toCPrinter {dict=m} = (funsigs, foldr funbody [] (toList m)) +where + funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m] + pfname n c = ["print_", n:c] + pfcall r n c = pfname n ["(", r, ", put);":c] + funsig n c = + ["void ":pfname n ["(\n" + : ind 1 $ typeName n m [" r,\n" + : ind 1 ["void (*put)(uint8_t))" + :c]]]] + funbody (n, ty) c = funsig n ["\n{\n":funb ty ["}\n":c]] + + funb (CTTypeDef a) c = ind 1 $ pfcall "r" a ["\n":c] + funb (CTEnum a) c = ind 1 ["put(r)\n":c] + funb (CTStruct [(_, fs)]) c = foldr (sfield 1 "r") c fs + funb (CTStruct fs) c = + ind 1 ["put(r.cons);\n" + : ind 1 ["switch(r.cons) {\n" + :foldr field + ( ind 1 ["default:\n" + : ind 2 ["break;\n" + : ind 1 ["}\n":c]]]) fs]] + where + field (n, []) c = c + field (n, fs) c + = ind 1 ["case ", n, ":\n" + : foldr (sfield 2 ("r.data."+++ n)) + (ind 2 ["break;\n":c]) fs] + + sfield i r (ty, ptr, f) c + = ind i $ pfcall (concat [if ptr "*" "", r, ".", f]) ty ["\n":c] + +toCValue :: a [Char] -> [Char] | gToCValue{|*|} a +toCValue a c = gToCValue{|*|} a c + +gToCValue{|Char|} x c = [x:c] +gToCValue{|Int|} x c = + [ toChar (x >> 56) + , toChar (x >> 48) + , toChar (x >> 40) + , toChar (x >> 32) + , toChar (x >> 24) + , toChar (x >> 16) + , toChar (x >> 8) + , toChar x:c] +gToCValue{|Bool|} x c = [toChar (if x 1 0):c] +gToCValue{|UNIT|} x c = c +gToCValue{|EITHER|} l _ (LEFT x) c = l x c +gToCValue{|EITHER|} _ r (RIGHT x) c = r x c +gToCValue{|PAIR|} l r (PAIR x y) c = l x $ r y c +gToCValue{|CONS of {gcd_index}|} f (CONS x) c = [toChar gcd_index:f x c] +gToCValue{|FIELD|} f (FIELD x) c = f x c +gToCValue{|RECORD|} f (RECORD x) c = f x c +gToCValue{|OBJECT|} f (OBJECT x) c = f x c + +fromCValue :: [Char] -> Either FromCValueError (a, [Char]) | gFromCValue{|*|} a +fromCValue i = gFromCValue{|*|} i + +:: Parser a :== [Char] -> Either FromCValueError (a, [Char]) +top :: Parser Char +top = satisfy (\_->True) CVEInputExhausted + +satisfy :: (Char -> Bool) FromCValueError -> Parser Char +satisfy f e = \c->case c of + [c:cs] + | f c = Right (c, cs) + = Left e + [] = Left CVEInputExhausted + +yield :: a -> Parser a +yield a = \c->Right (a, c) + +list :: [Parser a] -> Parser [a] +list [] = yield [] +list [x:xs] = cons <<$>> x <<*>> list xs + +cons x xs = [x:xs] + +(<<$>>) infixl 4 :: (a -> b) (Parser a) -> Parser b +(<<$>>) f a = fmap (\(a, b)->(f a, b)) <$> a + +(<<*>>) infixl 4 :: (Parser (a -> b)) (Parser a) -> Parser b +(<<*>>) f a = either Left (\(fa, c)->(fa <<$>> a) c) o f + +(<<|>>) infixr 4 :: (Parser a) (Parser a) -> Parser a +(<<|>>) l r = \c->either (\_->r c) Right $ l c + +int b = sum <<$>> list [(\x->toInt x << (i*8)) <<$>> top \\i<-[b-1,b-2..0]] +gFromCValue{|Char|} = top +gFromCValue{|Int|} = fromInt <<$>> int 8 +gFromCValue{|Bool|} = ((==) '\1') <<$>> top +gFromCValue{|UNIT|} = yield UNIT +gFromCValue{|EITHER|} l r = (LEFT <<$>> l) <<|>> (RIGHT <<$>> r) +gFromCValue{|PAIR|} l r = PAIR <<$>> l <<*>> r +gFromCValue{|CONS of {gcd_index}|} f + = (\x->CONS) <<$>> satisfy ((==)(toChar gcd_index)) CVEUnknownConstructor <<*>> f +gFromCValue{|FIELD|} f = (\x->FIELD x) <<$>> f +gFromCValue{|RECORD|} f = RECORD <<$>> f +gFromCValue{|OBJECT|} f = (\x->OBJECT x) <<$>> f + +toCFiles :: (Box String a) -> ([String], [String]) | gToStruct{|*|} a +toCFiles b=:(Box fn) + # (padefs, paimp) = toCParser gts + # (prdefs, primp) = toCPrinter gts + = + ( flatten + [["#ifndef ", guard, "\n" + , "#define ", guard, "\n" + , "#include \n" + , "#include \n" + , "#include \n"] + , toCType gts, padefs, prdefs + , ["#endif\n"] + ] + , flatten + [["#include \"", fn, ".h\"\n"] + , paimp + , primp] + ) +where + guard = {safe c\\c<-:fn +++ ".h"} + safe c + | not (isAlphanum c) = '_' + = toUpper c + gts = unBox (cast b) + + cast :: (Box x a) -> (Box GTSState a) | gToStruct{|*|} a + cast _ = toStruct diff --git a/structs/scc.dcl b/structs/scc.dcl new file mode 100644 index 0000000..c683730 --- /dev/null +++ b/structs/scc.dcl @@ -0,0 +1,13 @@ +definition module scc + +from StdOverloaded import class <, class == +from StdClass import class Ord, class Eq + +/* + * Find all strongly connected components using tarjan's algorithm + * see: https://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm + * + * @param list of nodes together with their successors + * @return the strongly connected components + */ +scc :: ![(a, [a])] -> [[a]] | Eq, Ord a diff --git a/structs/scc.icl b/structs/scc.icl new file mode 100644 index 0000000..408e647 --- /dev/null +++ b/structs/scc.icl @@ -0,0 +1,41 @@ +implementation module scc + +import StdEnv, StdMaybe +import Data.Map => qualified updateAt + +:: St a = {nextindex :: !Int, stack :: ![a], map :: !Map a Annot, sccs :: ![[a]]} +:: Annot = {index :: !Int, lowlink :: !Int, onstack :: !Bool} + +scc :: ![(a, [a])] -> [[a]] | Eq, Ord a +scc nodes = reverse (foldr (strongconnect nodes) {nextindex=zero,stack=[],map=newMap,sccs=[]} nodes).sccs +where + strongconnect :: ![(a, [a])] !(a, [a]) !(St a) -> St a | Eq, Ord a + strongconnect nodes (v, suc) s + | isJust (get v s.map) = s + # s = foldr (processSucc nodes v) + { s & map = put v {index=s.nextindex, lowlink=s.nextindex, onstack=True} s.map + , stack = [v:s.stack] + , nextindex = inc s.nextindex + } suc + # (Just a) = get v s.map + | a.index <> a.lowlink = s + # (scc, [sl:stack]) = span ((<>) v) s.stack + # scc = scc ++ [sl] + = { s & sccs = [scc:s.sccs] + , stack = stack + , map = foldr (alter \(Just s)->Just {s & onstack=False}) s.map scc + } + where + processSucc :: ![(a, [a])] !a !a !(St a) -> St a | Eq, Ord a + processSucc nodes v w s = case get w s.map of + Nothing + # n = filter ((==)w o fst) nodes + | n =: [] = s + # s = strongconnect nodes (hd n) s + # (Just aw) = get w s.map + # (Just av) = get v s.map + = {s & map=put v {av & lowlink=min av.lowlink aw.lowlink} s.map} + Just aw=:{onstack=True} + # (Just av) = get v s.map + = {s & map=put v {av & lowlink=min aw.index av.lowlink} s.map} + Just _ = s diff --git a/structs/test.icl b/structs/test.icl new file mode 100644 index 0000000..8585bd0 --- /dev/null +++ b/structs/test.icl @@ -0,0 +1,19 @@ +module test + +import GenC + +:: List a = Nil | Cons a (List a) +:: NInt =: NInt Int +:: T = A | B | C +:: R = {i :: Int, q :: T} +:: Muta a = Muta (Mutb a) +:: Mutb a = Mutb (Muta a) +derive gToStruct NInt, T, List, R, Muta, Mutb, (,), (), [], (,,) +derive gPotInf NInt, T, List, R, Muta, Mutb, (,), (), [], (,,) + +Start = (toCFiles t) +where + t :: Box String (List (Muta Int)) +// t :: Box GTSState NInt + t = Box "listmutaint" + -- 2.20.1