├── os ├── haskell │ ├── .gitignore │ ├── .ghci │ ├── Haskell │ │ ├── Types.hs │ │ ├── Monad │ │ │ ├── Assembler.hs │ │ │ └── Assembler │ │ │ │ └── Class.hs │ │ ├── Util │ │ │ └── Lifts.hs │ │ ├── Util.hs │ │ ├── Inspect.hs │ │ ├── RetypeData │ │ │ └── TH.hs │ │ ├── OS │ │ │ └── TH │ │ │ │ └── Accessors.hs │ │ ├── Pretty.hs │ │ └── Assembler.hs │ ├── Makefile │ └── Toplevel.hs ├── .gitignore ├── extraction.v ├── extra │ ├── nominal.hs │ ├── fingroup.hs │ ├── fault_handler.hs │ ├── tuple.hs │ ├── datatypes.hs │ ├── prime.hs │ ├── vector.hs │ ├── ord.hs │ ├── seq.hs │ ├── word.hs │ ├── choice.hs │ ├── ssreflect.hs │ ├── fintype.hs │ ├── common.hs │ ├── ssrnum.hs │ ├── hseq.hs │ ├── eqtype.hs │ ├── ssralg.hs │ ├── types.hs │ ├── symbolic.hs │ ├── finset.hs │ ├── concrete.hs │ └── symbolic0.hs ├── Makefile ├── os.v └── os.tex ├── extraction └── postprocess │ ├── .gitignore │ ├── Setup.hs │ ├── src │ ├── Postprocess │ │ ├── Util │ │ │ ├── Haskell.hs │ │ │ ├── Tuple.hs │ │ │ ├── Monoid.hs │ │ │ ├── Text.hs │ │ │ └── List.hs │ │ ├── Processor.hs │ │ ├── Imports.hs │ │ ├── Clean.hs │ │ ├── FileStructure.hs │ │ └── Constraints.hs │ ├── Postprocess.hs │ └── Main.hs │ ├── Makefile │ ├── README-ICU-MAC.txt │ ├── LICENSE │ └── postprocess.cabal ├── testing ├── README ├── .dir-locals.el └── Generation.v ├── .gitignore ├── sealing ├── classes.v └── symbolic.v ├── compartmentalization ├── ranges.v ├── common.v ├── isolate_sets.v └── global-hint.el ├── lib ├── haskell_notation.v ├── ssr_list_utils.v ├── word_utils.v ├── ssr_set_utils.v └── fmap_utils.v ├── README.md ├── cfi ├── classes.v ├── property.v ├── rules.v └── concrete.v ├── memory_safety ├── classes.v ├── property.v ├── propertyS.v ├── executable.v └── main.v ├── LICENSE ├── _CoqProject ├── ifc ├── noninterferenceS.v ├── common.v ├── abstract.v ├── labels.v └── symbolic.v ├── common ├── segment.v └── printing.v ├── concrete └── int_32.v ├── Makefile └── symbolic ├── int_32.v └── exec.v /os/haskell/.gitignore: -------------------------------------------------------------------------------- 1 | compiled 2 | -------------------------------------------------------------------------------- /extraction/postprocess/.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | -------------------------------------------------------------------------------- /os/.gitignore: -------------------------------------------------------------------------------- 1 | extracted/ 2 | os.pdf 3 | -------------------------------------------------------------------------------- /extraction/postprocess/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /os/extraction.v: -------------------------------------------------------------------------------- 1 | Require Import extraction.extraction os.os. 2 | Recursive Extraction Library os. 3 | -------------------------------------------------------------------------------- /os/haskell/.ghci: -------------------------------------------------------------------------------- 1 | :set -i../extracted 2 | :set -Wall -fno-warn-name-shadowing 3 | :seti -fno-warn-type-defaults 4 | -------------------------------------------------------------------------------- /os/extra/nominal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show Coq_name 5 | -------------------------------------------------------------------------------- /testing/README: -------------------------------------------------------------------------------- 1 | - Run the tests by running make 2 | - Install QuickChick before (git@github.com:lemonidas/QuickChick.git) 3 | 4 | -------------------------------------------------------------------------------- /os/extra/fingroup.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show Coq_rcoset_repr_spec 5 | -------------------------------------------------------------------------------- /os/extra/fault_handler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show Coq_policy_invariant 5 | -------------------------------------------------------------------------------- /os/Makefile: -------------------------------------------------------------------------------- 1 | extract: 2 | $(MAKE) -C .. extract-os 3 | 4 | clean: 5 | -rm -rf extracted/ 6 | -$(MAKE) -C haskell clean 7 | 8 | .PHONY: extract clean 9 | -------------------------------------------------------------------------------- /os/extra/tuple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show t => Prelude.Show (Coq_tuple1_spec t) 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.aux 2 | *.log 3 | *.out 4 | *.nav 5 | *.snm 6 | *.toc 7 | *.bak 8 | .coq-native 9 | main.pdf 10 | temp 11 | *.glob 12 | *.v.d 13 | *.vo 14 | Makefile.coq 15 | -------------------------------------------------------------------------------- /os/extra/datatypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show CompareSpecT 5 | deriving instance Prelude.Show (Coq_identity a) 6 | -------------------------------------------------------------------------------- /os/extra/prime.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show Coq_elogn2_spec 5 | deriving instance Prelude.Show (Coq_ifnz_spec t) 6 | -------------------------------------------------------------------------------- /os/extra/vector.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show Coq_addv_expr 5 | deriving instance Prelude.Show Coq_proper_addv_expr 6 | -------------------------------------------------------------------------------- /os/extra/ord.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show Ord__Total__Coq_mixin_of 5 | deriving instance Prelude.Show Ord__Coq_compare_ord 6 | -------------------------------------------------------------------------------- /os/extra/seq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show t => Prelude.Show (Coq_last_spec t) 5 | deriving instance Prelude.Show Coq_rot_to_spec 6 | -------------------------------------------------------------------------------- /os/extra/word.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | deriving instance Prelude.Eq Coq_word 4 | deriving instance Prelude.Ord Coq_word 5 | 6 | -- `Show' instances 7 | deriving instance Prelude.Show Coq_word 8 | -------------------------------------------------------------------------------- /os/extra/choice.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show t => Prelude.Show (GenTree__Coq_tree t) 5 | 6 | {-# POSTPROCESS CONSTRAINT _Countable__coq_EqMixin :: Prelude.Ord 0 #-} 7 | -------------------------------------------------------------------------------- /os/extra/ssreflect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show (TheCanonical__Coq_put vT sT) 5 | deriving instance Prelude.Show (Coq_phantom t) 6 | deriving instance Prelude.Show (Coq_phant p) 7 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess/Util/Haskell.hs: -------------------------------------------------------------------------------- 1 | module Postprocess.Util.Haskell (isHaskellQualidChar) where 2 | 3 | import Data.Char 4 | 5 | isHaskellQualidChar :: Char -> Bool 6 | isHaskellQualidChar c = isAlphaNum c || c == '_' || c == '\'' || c == '.' 7 | -------------------------------------------------------------------------------- /sealing/classes.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat. 2 | Require Import common.types. 3 | 4 | Class sealing_syscall_addrs mt := { 5 | mkkey_addr : mword mt; 6 | seal_addr : mword mt; 7 | unseal_addr : mword mt 8 | }. 9 | -------------------------------------------------------------------------------- /testing/.dir-locals.el: -------------------------------------------------------------------------------- 1 | ((coq-mode . ( 2 | ;; HACK: Include everything at two levels, so that relative paths 3 | ;; make sense when editing a file at either level. 4 | (coq-load-path . ("../src" "./src" "../../" "../kernel" "../../kernel" "../"))))) 5 | 6 | -------------------------------------------------------------------------------- /os/haskell/Haskell/Types.hs: -------------------------------------------------------------------------------- 1 | module Haskell.Types (module Haskell.Types, Atom(..)) where 2 | 3 | import Types 4 | 5 | type PartMap k v = [(k,v)] 6 | type PartMap' v = PartMap () v 7 | 8 | -- These could also be lenses... 9 | 10 | val :: Atom v t -> v 11 | val = vala 12 | 13 | tag :: Atom v t -> t 14 | tag = taga 15 | -------------------------------------------------------------------------------- /os/extra/fintype.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show FiniteQuant__Coq_quantified 5 | deriving instance Prelude.Show Coq_pick_spec 6 | deriving instance Prelude.Show Coq_extremum_spec 7 | deriving instance Prelude.Show Coq_unlift_spec 8 | deriving instance Prelude.Show Coq_split_spec 9 | -------------------------------------------------------------------------------- /os/extra/common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | deriving instance Prelude.Eq Coq_compartmentalization_syscall_addrs 4 | deriving instance Prelude.Ord Coq_compartmentalization_syscall_addrs 5 | 6 | deriving instance Prelude.Eq Coq_where_from 7 | deriving instance Prelude.Ord Coq_where_from 8 | 9 | -- `Show' instances 10 | deriving instance Prelude.Show Coq_compartmentalization_syscall_addrs 11 | deriving instance Prelude.Show Coq_where_from 12 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess/Util/Tuple.hs: -------------------------------------------------------------------------------- 1 | module Postprocess.Util.Tuple (flat3, first3, second3, third3) where 2 | 3 | flat3 :: (a,(b,c)) -> (a,b,c) 4 | flat3 (a,(b,c)) = (a,b,c) 5 | 6 | first3 :: (a -> a') -> (a,b,c) -> (a',b,c) 7 | first3 f = \(a,b,c) -> (f a, b, c) 8 | 9 | second3 :: (b -> b') -> (a,b,c) -> (a,b',c) 10 | second3 f = \(a,b,c) -> (a, f b, c) 11 | 12 | third3 :: (c -> c') -> (a,b,c) -> (a,b,c') 13 | third3 f = \(a,b,c) -> (a, b, f c) 14 | -------------------------------------------------------------------------------- /compartmentalization/ranges.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat. 2 | From extructures Require Import ord. 3 | From CoqUtils Require Import word. 4 | Require Import common.types. 5 | 6 | Section WithClasses. 7 | 8 | Context {mt : machine_types} 9 | {ops : machine_ops mt} 10 | {spec : machine_ops_spec ops}. 11 | 12 | Local Notation word := (mword mt). 13 | Open Scope word_scope. 14 | Open Scope ord_scope. 15 | 16 | Definition range (l h : word) := [pred e | l <= e <= h]. 17 | 18 | End WithClasses. 19 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess/Util/Monoid.hs: -------------------------------------------------------------------------------- 1 | module Postprocess.Util.Monoid (nonemptyIfNonnull, (?+++), (+++?), (??++), (++??)) where 2 | 3 | nonemptyIfNonnull :: Monoid m => [a] -> [m] 4 | nonemptyIfNonnull xs = [mempty | not $ null xs] 5 | 6 | (?+++), (+++?), (??++), (++??) :: Monoid m => [m] -> [m] -> [m] 7 | xs ?+++ ys = xs ++ nonemptyIfNonnull xs ++ ys 8 | xs +++? ys = xs ++ nonemptyIfNonnull ys ++ ys 9 | xs ??++ ys = nonemptyIfNonnull xs ++ xs ++ nonemptyIfNonnull xs ++ ys 10 | xs ++?? ys = xs ++ nonemptyIfNonnull ys ++ ys ++ nonemptyIfNonnull ys 11 | infixr 5 ?+++ , +++? , ??++ , ++?? 12 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess/Util/Text.hs: -------------------------------------------------------------------------------- 1 | module Postprocess.Util.Text (replaceAll) where 2 | 3 | import Data.Monoid 4 | 5 | import Data.Maybe 6 | 7 | import Data.Text (Text) 8 | import Data.Text.ICU (Regex) 9 | import qualified Data.Text.ICU as ICU 10 | 11 | replaceAll :: Regex -> Text -> Text -> Text 12 | replaceAll needle replacement = go where 13 | go haystack = case ICU.find needle haystack of 14 | Just match -> fromJust (ICU.prefix 0 match) 15 | <> replacement 16 | <> go (fromJust (ICU.suffix 0 match)) 17 | Nothing -> haystack 18 | -------------------------------------------------------------------------------- /os/haskell/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | ghc -i../extracted \ 3 | -Wall -fno-warn-name-shadowing \ 4 | -j \ 5 | -odir compiled -hidir compiled \ 6 | $$(find . -type f -name '*.hs') 7 | # Can't specify -O or -O2, or I get a "ghc: panic! (the 'impossible' happened)". 8 | # It's probably for the best, given the crazy `unsafePerformIO` shenanigans the 9 | # extracted code does with `()` (and not `Any`, grr). 10 | 11 | extract: 12 | $(MAKE) -C .. extract 13 | 14 | clean: 15 | -rm -rf compiled 16 | 17 | clean-all: 18 | -$(MAKE) -C .. clean 19 | -$(MAKE) clean 20 | 21 | .PHONY: all extract clean clean-all 22 | -------------------------------------------------------------------------------- /extraction/postprocess/Makefile: -------------------------------------------------------------------------------- 1 | postprocess: dist/build/postprocess/postprocess 2 | cp dist/build/postprocess/postprocess postprocess 3 | 4 | dist/build/postprocess/postprocess: Setup.hs src/Postprocess/Util/Tuple.hs src/Postprocess/Util/Monoid.hs src/Postprocess/Util/List.hs src/Postprocess/Util/Text.hs src/Postprocess/Util/Haskell.hs src/Postprocess/Processor.hs src/Postprocess/FileStructure.hs src/Postprocess/Imports.hs src/Postprocess/Constraints.hs src/Postprocess/Clean.hs src/Postprocess.hs src/Main.hs 5 | cabal configure 6 | cabal install --only-dependencies 7 | cabal build 8 | 9 | clean: 10 | cabal clean 11 | rm -f postprocess 12 | -------------------------------------------------------------------------------- /lib/haskell_notation.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun. 2 | 3 | Require Import lib.utils. 4 | 5 | (* Monadic function composition *) 6 | Definition opt_compose {A B C} 7 | (f : B -> option C) 8 | (g : A -> option B) 9 | : A -> option C := 10 | obind f \o g. 11 | Infix "<=<" := opt_compose (at level 30). 12 | Arguments opt_compose {A B C} f g / x. 13 | 14 | Infix "$" := (fun f x => f x) (at level 150, left associativity). 15 | Infix "<$>" := option_map (at level 130, left associativity). 16 | Infix "=<<" := obind (at level 130, left associativity). 17 | -------------------------------------------------------------------------------- /os/extra/ssrnum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show Num__Theory__Coq_ler_xor_gt 5 | deriving instance Prelude.Show Num__Theory__Coq_ltr_xor_ge 6 | deriving instance Prelude.Show Num__Theory__Coq_comparer 7 | deriving instance Prelude.Show Num__Theory__Coq_ger0_xor_lt0 8 | deriving instance Prelude.Show Num__Theory__Coq_ler0_xor_gt0 9 | deriving instance Prelude.Show Num__Theory__Coq_comparer0 10 | deriving instance Prelude.Show Num__Theory__Coq_sgr_val 11 | deriving instance Prelude.Show Num__Theory__Coq_minr_spec 12 | deriving instance Prelude.Show Num__Theory__Coq_maxr_spec 13 | deriving instance Prelude.Show Num__Theory__Coq_sqrtr_spec 14 | -------------------------------------------------------------------------------- /lib/ssr_list_utils.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq. 2 | 3 | Require Import lib.utils. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Set Bullet Behavior "Strict Subproofs". 10 | 11 | Definition rem_all {T : eqType} : T -> seq T -> seq T := 12 | filter \o predC1. 13 | 14 | (* This corollary's proof is so trivial, you'd think we could always use 15 | `rewrite mem_filter /=` instead. That's true, but I'd rather have an actual 16 | lemma so that we're not dependent on implementation details. *) 17 | Corollary in_rem_all (T : eqType) (a b : T) (xs : seq T) : 18 | a \in rem_all b xs = (a != b) && (a \in xs). 19 | Proof. by rewrite mem_filter. Qed. 20 | -------------------------------------------------------------------------------- /os/extra/hseq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | hseq_compare :: (a1 -> Eqtype.Equality__Coq_type) -> ([] a1) -> 4 | Coq_hseq a1 Eqtype.Equality__Coq_sort -> 5 | Coq_hseq a1 Eqtype.Equality__Coq_sort -> 6 | Prelude.Ordering 7 | hseq_compare t_ idx hs1 hs2 = 8 | case idx of { 9 | [] -> Prelude.EQ; 10 | (:) i idx0 -> 11 | (Data.Monoid.<>) 12 | (Eqtype.compare_op (t_ i) (hshead i idx0 (unsafeCoerce hs1)) 13 | (hshead i idx0 (unsafeCoerce hs2))) 14 | (hseq_compare t_ (Seq.behead ((:) i idx0)) (hsbehead ((:) i idx0) hs1) 15 | (hsbehead ((:) i idx0) hs2))} 16 | 17 | -- `Show' instances 18 | deriving instance Prelude.Show Coq_hseq_nil 19 | deriving instance (Prelude.Show t, Prelude.Show s) => Prelude.Show (Coq_hseq_cons t s) 20 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess/Processor.hs: -------------------------------------------------------------------------------- 1 | module Postprocess.Processor ( 2 | Document, Processor, Scanner, 3 | run, runReplacingFile 4 | ) where 5 | 6 | import Data.Text (Text) 7 | import qualified Data.Text as T 8 | import qualified Data.Text.IO as T 9 | 10 | import System.Directory 11 | 12 | type Document = [Text] 13 | type Processor = Document -> Document 14 | type Scanner a = Document -> a 15 | 16 | run :: Processor -> Text -> Text 17 | run p = T.unlines . p . T.lines 18 | 19 | runReplacingFile :: FilePath -> FilePath -> Processor -> IO () 20 | runReplacingFile from to p = do 21 | txt <- run p <$> T.readFile from 22 | -- The removal has to come after the read but before the write, so that we can 23 | -- overwrite a file in-place. 24 | removeFile from 25 | T.writeFile to txt 26 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess/Util/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | module Postprocess.Util.List (withBetween, (??)) where 4 | 5 | withBetween :: (a -> Bool) -> (a -> Bool) -> (a -> [a] -> a -> [a]) -> [a] -> [a] 6 | withBetween start end f = findStart where 7 | findStart [] = [] 8 | findStart (x:xs) 9 | | start x 10 | = case findEnd xs of 11 | Just (body, e, rest) -> f x body e ++ findStart rest 12 | Nothing -> x : xs 13 | | otherwise 14 | = x : findStart xs 15 | 16 | findEnd (break end -> (body, e:rest)) = Just (body, e, rest) 17 | findEnd _ = Nothing 18 | 19 | (??) :: (Eq i, Integral i) => [a] -> i -> Maybe a 20 | [] ?? _ = Nothing 21 | (x:xs) ?? i = case i `compare` 0 of 22 | LT -> Nothing 23 | EQ -> Just x 24 | GT -> xs ?? (i-1) 25 | -------------------------------------------------------------------------------- /os/extra/eqtype.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | data Equality__Coq_mixin_of t = 4 | Equality__Mixin (Ssrbool.Coq_rel t) (Equality__Coq_axiom t) (t -> t -> Prelude.Ordering) 5 | 6 | equality__mixin :: Prelude.Ord t => Ssrbool.Coq_rel t -> Equality__Coq_axiom t -> Equality__Coq_mixin_of t 7 | equality__mixin eqb eqP = Equality__Mixin eqb eqP Prelude.compare 8 | 9 | compare_op :: Equality__Coq_type -> () -> () -> Prelude.Ordering 10 | compare_op (Equality__Mixin _ _ cmp) = cmp 11 | 12 | -- `Show' instances 13 | deriving instance Prelude.Show t => Prelude.Show (Sub_spec t) 14 | deriving instance Prelude.Show (Coq_insub_spec t) 15 | 16 | {-# POSTPROCESS CONSTRAINT comparableClass :: Prelude.Ord 0 #-} 17 | {-# POSTPROCESS CONSTRAINT coq_InjEqMixin :: Prelude.Ord 0 #-} 18 | {-# POSTPROCESS CONSTRAINT coq_PcanEqMixin :: Prelude.Ord 0 #-} 19 | {-# POSTPROCESS CONSTRAINT coq_CanEqMixin :: Prelude.Ord 0 #-} 20 | -------------------------------------------------------------------------------- /os/extra/ssralg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | -- `Show' instances 4 | deriving instance Prelude.Show GRing__Pred__Coq_opp 5 | deriving instance Prelude.Show GRing__Pred__Coq_add 6 | deriving instance Prelude.Show GRing__Pred__Coq_mul 7 | deriving instance Prelude.Show GRing__Pred__Coq_zmod 8 | deriving instance Prelude.Show GRing__Pred__Coq_semiring 9 | deriving instance Prelude.Show GRing__Pred__Coq_smul 10 | deriving instance Prelude.Show GRing__Pred__Coq_div 11 | deriving instance Prelude.Show GRing__Pred__Coq_submod 12 | deriving instance Prelude.Show GRing__Pred__Coq_subring 13 | deriving instance Prelude.Show GRing__Pred__Coq_sdiv 14 | deriving instance Prelude.Show GRing__Pred__Coq_subalg 15 | deriving instance Prelude.Show GRing__Pred__Coq_divring 16 | deriving instance Prelude.Show GRing__Pred__Coq_divalg 17 | deriving instance Prelude.Show r => Prelude.Show (GRing__Coq_term r) 18 | deriving instance Prelude.Show r => Prelude.Show (GRing__Coq_formula r) 19 | -------------------------------------------------------------------------------- /extraction/postprocess/README-ICU-MAC.txt: -------------------------------------------------------------------------------- 1 | If you're having trouble installing the `text-icu` dependency on Mac OS X, I 2 | (Antal) found the following successful: 3 | 4 | 1. Install `icu4c` from [homebrew](http://brew.sh/), if you haven't already: 5 | 6 | brew info icu4c 7 | 8 | will check to see if `icu4c` is installed ("Built from source" or "Poured 9 | from bottle" lines indicate that it is; a "Not installed" line indicates 10 | that it's not); if necessary, then 11 | 12 | brew install icu4c 13 | 14 | will install `icu4c`. 15 | 16 | 2. Install `text-icu` while looking for those files: 17 | 18 | DYLD_LIBRARY_PATH=/usr/local/opt/icu4c/lib cabal install text-icu --extra-include-dirs=/usr/local/opt/icu4c/include --extra-lib-dirs=/usr/local/opt/icu4c/lib 19 | 20 | Your mileage with these instructions may vary, so feel free to edit this file or 21 | create an appropriate new one if you solve this (or another) problem in a 22 | different way! 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Micro-Policies in Coq 2 | 3 | ### Description 4 | 5 | Coq formalization accompanying the paper: 6 | - Micro-Policies: A Framework for Verified, Tag-Based Security Monitors. Arthur 7 | Azevedo de Amorim, Maxime Dénès, Nick Giannarakis, Cătălin Hriţcu, Benjamin 8 | C. Pierce, Antal Spector-Zabusky, Andrew Tolmach. In 36th IEEE Symposium on 9 | Security and Privacy (Oakland S&P), 10 | May 2015. (http://prosecco.gforge.inria.fr/personal/hritcu/publications/micro-policies.pdf) 11 | 12 | ### Prerequisites 13 | 14 | - Coq version v8.9 (https://coq.inria.fr/download) 15 | - The Mathematical Components library v1.9 16 | (http://www.msr-inria.fr/projects/mathematical-components-2/) 17 | - The Extensional Structures library v0.2 (https://github.com/arthuraa/extructures) 18 | - The CoqUtils library, commit ce97408b (https://github.com/arthuraa/coq-utils) 19 | 20 | ### Compiling 21 | 22 | make -j 23 | 24 | ### License 25 | 26 | This development is distributed under the MIT license (see `LICENSE`) 27 | -------------------------------------------------------------------------------- /os/haskell/Haskell/Monad/Assembler.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module : Haskell.Monad.Assembler 3 | Description : Monad transformer and class for assembling a Von Neumann-architecture machine 4 | Copyright : © 2015 Antal Spector-Zabusky 5 | License : BSD3 6 | Maintainer : Antal Spector-Zabusky 7 | Stability : experimental 8 | Portability : GHC only 9 | 10 | This module provides an 'AssemblerT' monad transformer and a 'MonadAssembler' 11 | monad class, which represent monads that support generating the memory of a Von 12 | Neumann-architecture machine. For more information and documentation see 13 | "Haskell.Monad.Trans.Assembler" and, to a lesser extent, 14 | "Haskell.Monad.Assembler.Class". 15 | -} 16 | 17 | module Haskell.Monad.Assembler ( 18 | module Haskell.Monad.Assembler.Class, 19 | module Haskell.Monad.Trans.Assembler 20 | ) where 21 | 22 | import Haskell.Monad.Assembler.Class 23 | import Haskell.Monad.Trans.Assembler hiding 24 | ( asmWord, asmWords, reserve 25 | , here, reservedSegment 26 | , asmError, asmDelayedError 27 | , program ) 28 | -------------------------------------------------------------------------------- /extraction/postprocess/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Antal Spector-Zabusky et al. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /cfi/classes.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat. 2 | Require Import common.types. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | Class cfi_id mt := { 9 | id : eqType; 10 | 11 | word_to_id : mword mt -> option id; 12 | id_to_word : id -> mword mt; 13 | 14 | id_to_wordK : forall x, word_to_id (id_to_word x) = Some x; 15 | word_to_idK : forall w x, word_to_id w = Some x -> id_to_word x = w 16 | 17 | }. 18 | 19 | Section ControlFlow. 20 | 21 | Context {mt : machine_types} 22 | {ids : @cfi_id mt}. 23 | 24 | Variable cfg : id -> id -> bool. 25 | 26 | Definition valid_jmp w1 w2 := 27 | match word_to_id w1, word_to_id w2 with 28 | | Some id1, Some id2 => cfg id1 id2 29 | | _, _ => false 30 | end. 31 | 32 | Lemma valid_jmp_true w1 w2 : 33 | valid_jmp w1 w2 -> 34 | exists id1 id2, 35 | word_to_id w1 = Some id1 /\ 36 | word_to_id w2 = Some id2. 37 | Proof. 38 | unfold valid_jmp. 39 | intro VALID. 40 | destruct (word_to_id w1) eqn:W1, (word_to_id w2) eqn:W2; 41 | try discriminate. 42 | by eexists; eauto. 43 | Qed. 44 | 45 | End ControlFlow. 46 | -------------------------------------------------------------------------------- /memory_safety/classes.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. 2 | Require Import common.types. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | Inductive syscall := Malloc | Free | Size | Base | Eq. 9 | 10 | Scheme Equality for syscall. 11 | 12 | Lemma syscall_eqP : Equality.axiom syscall_beq. 13 | Proof. 14 | move=> sc1 sc2; apply/(iffP idP). 15 | exact: internal_syscall_dec_bl. 16 | exact: internal_syscall_dec_lb. 17 | Qed. 18 | 19 | Definition syscall_eqMixin := EqMixin syscall_eqP. 20 | 21 | Canonical syscall_eqType := Eval hnf in EqType syscall syscall_eqMixin. 22 | 23 | Definition syscalls := 24 | [:: Malloc; Free; Size; Base; Eq]. 25 | 26 | Class memory_syscall_addrs mt := { 27 | addr : syscall -> mword mt; 28 | uniq_addr : injective addr 29 | }. 30 | 31 | Section Syscalls. 32 | 33 | Context mt {sc : memory_syscall_addrs mt}. 34 | 35 | Definition syscall_of_addr (a : mword mt) := 36 | nth None (map some syscalls) 37 | (find (pred1 a) [seq addr sc | sc <- syscalls]). 38 | 39 | Lemma addrK : pcancel addr syscall_of_addr. 40 | Proof. 41 | by case; rewrite /syscall_of_addr /= !(inj_eq (@uniq_addr _ sc)). 42 | Qed. 43 | 44 | End Syscalls. 45 | -------------------------------------------------------------------------------- /os/extra/types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} 2 | 3 | data Atom v t = v :@ t 4 | deriving ( Prelude.Eq, Prelude.Ord, Prelude.Read, Prelude.Show 5 | , Prelude.Functor 6 | , Data.Foldable.Foldable, Data.Traversable.Traversable ) 7 | infix 9 :@ 8 | 9 | instance Data.Bifunctor.Bifunctor Atom where 10 | bimap vf tf (v :@ t) = vf v :@ tf t 11 | 12 | deriving instance Prelude.Eq Coq_binop 13 | deriving instance Prelude.Ord Coq_binop 14 | deriving instance Prelude.Enum Coq_binop 15 | 16 | deriving instance Prelude.Eq Coq_opcode 17 | deriving instance Prelude.Ord Coq_opcode 18 | 19 | deriving instance Prelude.Eq Coq_vopcode 20 | deriving instance Prelude.Ord Coq_vopcode 21 | 22 | deriving instance Prelude.Eq Coq_instr 23 | deriving instance Prelude.Ord Coq_instr 24 | 25 | -- `Show' instances 26 | deriving instance Prelude.Show Coq_binop 27 | deriving instance Prelude.Show Coq_opcode 28 | deriving instance Prelude.Show Coq_vopcode 29 | deriving instance Prelude.Show Coq_machine_types 30 | deriving instance Prelude.Show Coq_instr 31 | deriving instance Prelude.Show Coq_machine_ops_spec 32 | deriving instance Prelude.Show Coq_syscall_regs 33 | -------------------------------------------------------------------------------- /lib/word_utils.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import 2 | ssreflect ssrbool ssrfun eqtype ssrnat fintype div ssrint intdiv. 3 | From extructures Require Import ord. 4 | From CoqUtils Require Import word. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | 10 | Section WordUtils. 11 | 12 | Local Open Scope word_scope. 13 | Local Open Scope ord_scope. 14 | 15 | Lemma leqw_succ : forall n (x y : word n), x < y -> x < x + 1. 16 | Proof. 17 | move=> n [[x Px]] [[y Py]]; do !rewrite ?Ord.ltNge !/Ord.leq /=. 18 | rewrite -!ltnNge !modz_nat !absz_nat !modn_mod. 19 | case: n Px Py => [|k Px Py Pxy] /=. 20 | by rewrite expn0 modn1; case: x y => [|x] [|y]. 21 | rewrite !modn_small ?(addn1, leqnn) //; 22 | try by rewrite -{1}(expn0 2) ltn_exp2l. 23 | by apply: (@leq_trans y.+1). 24 | Qed. 25 | 26 | Lemma addw_le : forall n (x y : word n), 27 | x < y -> x + 1 <= y. 28 | Proof. 29 | move=> n [[x Px]] [[y Py]]; do !rewrite ?Ord.ltNge !/Ord.leq /=. 30 | rewrite -!ltnNge /= !modz_nat !absz_nat !modn_mod. 31 | case: n Px Py => [|k Px Py Pxy] /=. 32 | by rewrite expn0 modn1; case: x y => [|x] [|y]. 33 | rewrite !modn_small ?(addn1, leqnn) //; 34 | try by rewrite -{1}(expn0 2) ltn_exp2l. 35 | by apply: (@leq_trans y.+1). 36 | Qed. 37 | 38 | End WordUtils. 39 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (aka Expat License) 2 | 3 | Copyright (c) 2013-2017 Arthur Azevedo de Amorim, Maxime Dénès, 4 | Nick Giannarakis, Catalin Hritcu, Benjamin C. Pierce, 5 | Antal Spector-Zabusky, and Andrew Tolmach 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 23 | THE SOFTWARE. 24 | -------------------------------------------------------------------------------- /compartmentalization/common.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. 2 | From extructures Require Import ord fmap. 3 | From CoqUtils Require Import word. 4 | Require Import lib.utils common.types. 5 | Set Bullet Behavior "Strict Subproofs". 6 | 7 | Generalizable All Variables. 8 | 9 | Class compartmentalization_syscall_addrs (mt : machine_types) := { 10 | isolate_addr : mword mt; 11 | add_to_jump_targets_addr : mword mt; 12 | add_to_store_targets_addr : mword mt 13 | }. 14 | 15 | Definition syscall_addrs {mt} {c : compartmentalization_syscall_addrs mt} : seq (mword mt) := 16 | [:: isolate_addr; add_to_jump_targets_addr; add_to_store_targets_addr]. 17 | 18 | Inductive where_from := 19 | | INTERNAL : where_from 20 | | JUMPED : where_from. 21 | 22 | Definition where_from_eq (S1 S2 : where_from) : bool := 23 | match S1, S2 with 24 | | INTERNAL , INTERNAL | JUMPED , JUMPED => true 25 | | _ , _ => false 26 | end. 27 | 28 | Lemma where_from_eqP : Equality.axiom where_from_eq. 29 | Proof. by move=> [|] [|] /=; apply: (iffP idP). Qed. 30 | 31 | Definition where_from_eqMixin := EqMixin where_from_eqP. 32 | Canonical where_from_eqType := Eval hnf in EqType where_from where_from_eqMixin. 33 | 34 | Notation "x ?= y" := (x = Some y) (at level 70, no associativity). 35 | -------------------------------------------------------------------------------- /os/os.v: -------------------------------------------------------------------------------- 1 | Set Implicit Arguments. 2 | Unset Strict Implicit. 3 | Unset Printing Implicit Defensive. 4 | Set Bullet Behavior "Strict Subproofs". 5 | 6 | Set Printing Implicit. 7 | 8 | Require Import concrete.int_32. 9 | Require Import symbolic.symbolic symbolic.int_32 symbolic.exec. 10 | Require Import compartmentalization.common compartmentalization.symbolic. 11 | 12 | (* The only reason I am so explicit here is that this will be used from Haskell, 13 | where the exact instances must sometimes be inserted by hand. By being 14 | explicit here, I can avoid any unpleasant surprises. Of course, this was 15 | generated by inspecting the auto-type-class-instantiated original of `stepf 16 | Sym.syscalls`. *) 17 | 18 | Definition step_compartmentalized 19 | (syscalls : compartmentalization_syscall_addrs concrete_int_32_mt) 20 | : Symbolic.state concrete_int_32_mt 21 | -> option (Symbolic.state concrete_int_32_mt) 22 | := stepf (mt := concrete_int_32_mt) 23 | (ops := concrete_int_32_ops) 24 | (sp := Sym.sym_compartmentalization (mt := concrete_int_32_mt)) 25 | (Sym.syscalls (mt := concrete_int_32_mt) 26 | (ops := concrete_int_32_ops) 27 | (scr := concrete_int_32_scr) 28 | (cmp_syscalls := syscalls)). 29 | 30 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess/Imports.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, LambdaCase, OverloadedStrings #-} 2 | 3 | module Postprocess.Imports (getImportedModules, getReferencedModules) where 4 | 5 | import Data.Char 6 | import Data.Maybe 7 | 8 | import Language.Haskell.Exts.Parser (ParseResult(..)) 9 | import Language.Haskell.Exts.Lexer 10 | 11 | import Data.Set (Set) 12 | import qualified Data.Set as S 13 | 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | 17 | import Postprocess.Processor 18 | 19 | getImportedModules :: Scanner (Set Text) 20 | getImportedModules = 21 | S.fromList . mapMaybe ( fmap (T.takeWhile (not . isSpace)) 22 | . fmap (dropOptToken "qualified") 23 | . tryDropToken "import" 24 | . dropSpaces ) 25 | where 26 | dropSpaces = T.dropWhile isSpace 27 | -- Drops token + trailing space 28 | tryDropToken tok = fmap dropSpaces . T.stripPrefix tok 29 | dropOptToken tok = fromMaybe <*> tryDropToken tok 30 | 31 | getReferencedModules :: Scanner (Set Text) 32 | getReferencedModules (lexTokenStream . T.unpack . T.unlines -> ParseOk (map unLoc -> toks)) = 33 | S.fromList . flip mapMaybe toks $ fmap T.pack . \case 34 | QVarId (m,_) -> Just m 35 | QConId (m,_) -> Just m 36 | QVarSym (m,_) -> Just m 37 | QConSym (m,_) -> Just m 38 | _ -> Nothing 39 | getReferencedModules _ = 40 | S.empty 41 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess/Clean.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Postprocess.Clean (deCPP, changeReservedWords, fixOptions) where 4 | 5 | import Control.Monad 6 | import Data.Monoid 7 | 8 | import qualified Data.Text as T 9 | 10 | import qualified Data.Text.ICU as ICU 11 | 12 | import Postprocess.Util.List 13 | import Postprocess.Util.Text 14 | 15 | import Postprocess.Processor 16 | 17 | deCPP :: Processor 18 | deCPP = 19 | withBetween (== "#ifdef __GLASGOW_HASKELL__") (== "#endif") $ \_ text _ -> 20 | takeWhile (/= "#else") text 21 | 22 | changeReservedWords :: Processor 23 | changeReservedWords = map (unreserve $ ["rec", "mdo", "proc", "pattern"]) where 24 | unreserve = foldr (.) id . map word 25 | word w = replaceAll (ICU.regex [ ICU.Multiline 26 | , ICU.UnicodeWord] 27 | $ "\\b" <> w <> "\\b") 28 | ("reserved_word_" <> w) 29 | 30 | fixOptions :: Processor 31 | fixOptions = concatMap $ fixGHC >=> fixHugs where 32 | fixGHC str | "{-# OPTIONS_GHC" `T.isPrefixOf` str = 33 | do let ghc' = T.replace " -cpp " " " str 34 | guard $ ghc' /= "{-# OPTIONS_GHC #-}" 35 | return $ T.replace "#-}" "-w #-}" ghc' 36 | | otherwise = 37 | [str] 38 | 39 | fixHugs str | "{- For Hugs" `T.isPrefixOf` str = [] 40 | | otherwise = [str] 41 | -------------------------------------------------------------------------------- /extraction/postprocess/postprocess.cabal: -------------------------------------------------------------------------------- 1 | name: postprocess 2 | version: 0.0.1.0 3 | synopsis: Postprocess extracted Coq code for usability. 4 | license: MIT 5 | license-file: LICENSE 6 | author: Antal Spector-Zabusky 7 | maintainer: antal.b.sz@gmail.com 8 | copyright: Copyright (c) 2015 Antal Spector-Zabusky et al. 9 | category: Language 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | executable postprocess 14 | main-is: Main.hs 15 | other-modules: Postprocess.Util.Tuple 16 | , Postprocess.Util.Monoid 17 | , Postprocess.Util.List 18 | , Postprocess.Util.Text 19 | , Postprocess.Util.Haskell 20 | , Postprocess.Processor 21 | , Postprocess.FileStructure 22 | , Postprocess.Imports 23 | , Postprocess.Constraints 24 | , Postprocess.Clean 25 | , Postprocess 26 | build-depends: base >=4.6 && < 4.9 27 | , text >=1.1 && < 1.3 28 | , text-icu ==0.7.* 29 | , containers ==0.5.* 30 | , haskell-src-exts >=1.16 && < 1.18 31 | , filepath >=1.3 && < 1.5 32 | , directory ==1.2.* 33 | hs-source-dirs: src 34 | default-language: Haskell2010 35 | GHC-options: -Wall -Werror -O2 36 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess/FileStructure.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Postprocess.FileStructure ( 4 | splitPreambleImportsBody, 5 | partitionExtraPreambleImports, 6 | collectPreambleImportsBody 7 | ) where 8 | 9 | import Control.Arrow 10 | 11 | import Data.Char 12 | import Data.List 13 | 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | 17 | import Postprocess.Util.Tuple 18 | import Postprocess.Util.Monoid 19 | 20 | import Postprocess.Processor 21 | 22 | -- Preamble: up to and including the `module` line 23 | -- Imports: the imports (duh) 24 | -- Body: the rest of the module 25 | splitPreambleImportsBody :: Document -> (Document,Document,Document) 26 | splitPreambleImportsBody = 27 | break ("module" `T.isPrefixOf`) >>> shift 28 | >>> second (span $ (||) <$> ("import" `T.isPrefixOf`) <*> T.all isSpace) 29 | >>> flat3 30 | where 31 | shift (pre,mid:post) = (pre ++ [mid], post) 32 | shift (pre,[]) = (pre,[]) 33 | 34 | partitionExtraPreambleImports :: Document -> (Document,Document,Document) 35 | partitionExtraPreambleImports = 36 | partition ("{-#" `T.isPrefixOf`) 37 | >>> second (partition ("import" `T.isPrefixOf`)) 38 | >>> flat3 39 | 40 | collectPreambleImportsBody :: [Text] -> Document -> (Document,Document,Document) 41 | collectPreambleImportsBody extraBody doc = 42 | let (filePre, fileImp, fileBody) = splitPreambleImportsBody doc 43 | (extraPre, extraImp, body) = partitionExtraPreambleImports $ extraBody ?+++ fileBody 44 | in (extraPre ?+++ filePre, fileImp +++? extraImp, body) 45 | -------------------------------------------------------------------------------- /_CoqProject: -------------------------------------------------------------------------------- 1 | -arg "-w -parsing" 2 | -R . MicroPolicies 3 | 4 | lib/utils.v 5 | lib/haskell_notation.v 6 | lib/ssr_list_utils.v 7 | lib/ssr_set_utils.v 8 | lib/fmap_utils.v 9 | lib/word_utils.v 10 | 11 | common/types.v 12 | common/segment.v 13 | common/printing.v 14 | 15 | concrete/concrete.v 16 | concrete/exec.v 17 | concrete/int_32.v 18 | 19 | symbolic/symbolic.v 20 | symbolic/fault_handler.v 21 | symbolic/refinement_common.v 22 | symbolic/backward.v 23 | symbolic/forward.v 24 | symbolic/int_32.v 25 | symbolic/rules.v 26 | symbolic/exec.v 27 | 28 | cfi/property.v 29 | cfi/abstract.v 30 | cfi/rules.v 31 | cfi/symbolic.v 32 | cfi/refinementAS.v 33 | cfi/preservation.v 34 | cfi/preservationAS.v 35 | cfi/concrete.v 36 | cfi/refinementSC.v 37 | cfi/main.v 38 | cfi/classes.v 39 | 40 | memory_safety/classes.v 41 | memory_safety/abstract.v 42 | memory_safety/executable.v 43 | memory_safety/symbolic.v 44 | memory_safety/refinementAS.v 45 | memory_safety/property.v 46 | memory_safety/propertyA.v 47 | memory_safety/propertyS.v 48 | memory_safety/main.v 49 | 50 | compartmentalization/ranges.v 51 | compartmentalization/isolate_sets.v 52 | compartmentalization/common.v 53 | compartmentalization/abstract.v 54 | compartmentalization/symbolic.v 55 | compartmentalization/refinementSA.v 56 | compartmentalization/main.v 57 | 58 | sealing/classes.v 59 | sealing/abstract.v 60 | sealing/symbolic.v 61 | sealing/refinementSA.v 62 | sealing/main.v 63 | 64 | ifc/symbolic.v 65 | ifc/abstract.v 66 | ifc/refinementSA.v 67 | ifc/noninterference.v 68 | ifc/noninterferenceS.v 69 | ifc/labels.v 70 | ifc/common.v 71 | 72 | os/os.v 73 | 74 | extraction/extraction.v 75 | -------------------------------------------------------------------------------- /compartmentalization/isolate_sets.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import 2 | ssreflect ssrfun ssrbool eqtype ssrnat seq fintype finset ssrint. 3 | From extructures Require Import ord fmap. 4 | From CoqUtils Require Import word. 5 | 6 | Require Import lib.utils common.types. 7 | Require Import compartmentalization.ranges. 8 | 9 | Set Bullet Behavior "Strict Subproofs". 10 | Import DoNotation. 11 | 12 | Generalizable All Variables. 13 | 14 | Section WithClasses. 15 | 16 | Context {mt : machine_types} 17 | {ops : machine_ops mt} 18 | {spec : machine_ops_spec ops} 19 | {V : Type} 20 | (to_word : V -> mword mt). 21 | 22 | Open Scope word_scope. 23 | 24 | Definition isolate_get_range (m : {fmap mword mt -> V}) (p : mword mt) : option {set (mword mt)} := 25 | do! low <- m p; 26 | do! high <- m (p + 1); 27 | Some [set i : mword mt in range (to_word low) (to_word high)]. 28 | 29 | Fixpoint isolate_get_ranges (m : {fmap mword mt -> V}) 30 | (p : mword mt) 31 | (n : nat) : option {set (mword mt)} := 32 | match n with 33 | | O => Some set0 34 | | S n' => do! here <- isolate_get_range m p; 35 | do! rest <- isolate_get_ranges m (p + as_word 2) n'; 36 | Some (here :|: rest) 37 | end. 38 | 39 | Definition isolate_create_set (m : {fmap mword mt -> V}) 40 | (base : mword mt) : option {set (mword mt)} := 41 | do! pairs <- m base; 42 | isolate_get_ranges m (base + 1) (val (to_word pairs)). 43 | 44 | Local Notation "x ?= y" := (x = Some y) (at level 70, no associativity). 45 | 46 | End WithClasses. 47 | -------------------------------------------------------------------------------- /os/extra/symbolic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | deriving instance Prelude.Eq Symbolic__Coq_tag_kind 4 | deriving instance Prelude.Ord Symbolic__Coq_tag_kind 5 | 6 | _Exports__state_cmp :: Types.Coq_machine_types -> Symbolic__Coq_params -> 7 | Symbolic__Coq_state -> Symbolic__Coq_state -> Prelude.Ordering 8 | _Exports__state_cmp mt p s1 s2 = 9 | Data.Monoid.mconcat 10 | [ Eqtype.compare_op 11 | (Partmap._PartMap__Exports__partmap_eqType 12 | (Word.word_ordType (Types.word_size mt)) 13 | (Types.atom_eqType 14 | (Word.word_eqType (Types.word_size mt)) 15 | (_Symbolic__tag_type (_Symbolic__ttypes p) Symbolic__M))) 16 | (unsafeCoerce (_Symbolic__mem mt p s1)) 17 | (unsafeCoerce (_Symbolic__mem mt p s2)) 18 | , Eqtype.compare_op 19 | (Partmap._PartMap__Exports__partmap_eqType 20 | (Word.word_ordType (Types.reg_field_size mt)) 21 | (Types.atom_eqType 22 | (Word.word_eqType (Types.word_size mt)) 23 | (_Symbolic__tag_type (_Symbolic__ttypes p) Symbolic__R))) 24 | (unsafeCoerce (_Symbolic__regs mt p s1)) 25 | (unsafeCoerce (_Symbolic__regs mt p s2)) 26 | , Eqtype.compare_op 27 | (Types.atom_eqType 28 | (Word.word_eqType (Types.word_size mt)) 29 | (_Symbolic__tag_type (_Symbolic__ttypes p) Symbolic__P)) 30 | (unsafeCoerce (_Symbolic__pc mt p s1)) 31 | (unsafeCoerce (_Symbolic__pc mt p s2)) 32 | , Eqtype.compare_op 33 | (_Symbolic__internal_state p) 34 | (_Symbolic__internal mt p s1) 35 | (_Symbolic__internal mt p s2) ] 36 | 37 | -- `Show' instances 38 | deriving instance Prelude.Show Symbolic__Coq_tag_kind 39 | deriving instance Prelude.Show Symbolic__Coq_ivec 40 | deriving instance Prelude.Show Symbolic__Coq_ovec 41 | deriving instance Prelude.Show Symbolic__Coq_state 42 | -------------------------------------------------------------------------------- /memory_safety/property.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool seq eqtype. 2 | 3 | Require Import lib.utils. 4 | 5 | Set Implicit Arguments. 6 | Unset Strict Implicit. 7 | Unset Printing Implicit Defensive. 8 | 9 | Section Events. 10 | 11 | Variables (pT rT : eqType). 12 | Variable can_access : pT -> rT -> bool. 13 | 14 | Inductive event := 15 | | MemRead of pT & rT 16 | | MemWrite of pT & rT. 17 | 18 | Definition event_eq e1 e2 := 19 | match e1, e2 with 20 | | MemRead ptr1 reg1, MemRead ptr2 reg2 => 21 | (ptr1 == ptr2) && (reg1 == reg2) 22 | | MemWrite ptr1 reg1, MemWrite ptr2 reg2 => 23 | (ptr1 == ptr2) && (reg1 == reg2) 24 | | _, _ => false 25 | end. 26 | 27 | Lemma event_eqP : Equality.axiom event_eq. 28 | Proof. 29 | move=> [ptr1 reg1|ptr1 reg1] [ptr2 reg2|ptr2 reg2] /=; try by constructor. 30 | by apply/(equivP andP); split=> [[/eqP -> /eqP ->]|[-> ->]]. 31 | by apply/(equivP andP); split=> [[/eqP -> /eqP ->]|[-> ->]]. 32 | Qed. 33 | 34 | Definition event_eqMixin := EqMixin event_eqP. 35 | Canonical event_eqType := Eval hnf in EqType event event_eqMixin. 36 | 37 | End Events. 38 | 39 | Structure memory_safety_machine := MSMachine { 40 | state : eqType; 41 | pointer : eqType; 42 | region : eqType; 43 | can_access : pointer -> region -> bool; 44 | get_events : state -> seq (event pointer region); 45 | step : state -> state -> Prop 46 | }. 47 | 48 | Section FixMachine. 49 | 50 | Variable m : memory_safety_machine. 51 | 52 | Local Notation pT := (pointer m). 53 | Local Notation rT := (region m). 54 | Local Notation event := (event pT rT). 55 | 56 | Implicit Type e : event. 57 | 58 | Definition event_ok e := 59 | match e with 60 | | MemRead ptr reg => can_access ptr reg 61 | | MemWrite ptr reg => can_access ptr reg 62 | end. 63 | 64 | Definition memory_safety := 65 | forall t x y, intermr (@step m) t x y -> 66 | all event_ok (flatten (map (@get_events m) t)). 67 | 68 | End FixMachine. 69 | -------------------------------------------------------------------------------- /cfi/property.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. 2 | From extructures Require Import ord fmap. 3 | From CoqUtils Require Import word. 4 | Require Import lib.utils common.types. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | 10 | Section CFI. 11 | 12 | Context (mt : machine_types). 13 | Context {ops : machine_ops mt}. 14 | 15 | Local Notation word := (mword mt). 16 | 17 | Class cfi_machine := { 18 | state : eqType; 19 | initial : state -> Prop; 20 | 21 | step : state -> state -> Prop; 22 | step_a : state -> state -> Prop; 23 | 24 | succ : state -> state -> bool; 25 | stopping : seq state -> Prop 26 | }. 27 | 28 | Context (cfim : cfi_machine). 29 | 30 | (* Definitions regarding stepping relations for CFI *) 31 | Definition cfi_step st st' := step_a st st' \/ step st st'. 32 | 33 | Definition intermstep := interm cfi_step. 34 | 35 | Definition intermrstep := intermr cfi_step. 36 | 37 | (* Old definition of CFI (Abadi) 38 | Definition trace_has_cfi' (trace : seq state) := 39 | forall (si sj : state) 40 | (INTRACE : In2 si sj trace ), 41 | (step_a si sj /\ get_pc si = get_pc sj) 42 | \/ succ si sj. 43 | *) 44 | 45 | (* Our new CFI definition *) 46 | Definition trace_has_cfi (trace : seq state) := 47 | forall (si sj : state) 48 | (INTRACE : In2 si sj trace ), 49 | step si sj -> succ si sj. 50 | 51 | Definition trace_has_at_most_one_violation (trace : seq state) := 52 | trace_has_cfi trace \/ 53 | exists si sj hs tl, trace = hs ++ si :: sj :: tl 54 | /\ (step si sj /\ ~~ succ si sj) 55 | /\ trace_has_cfi (rcons hs si) 56 | /\ trace_has_cfi (sj :: tl) 57 | /\ stopping(sj :: tl). 58 | 59 | Definition cfi := 60 | forall s s' xs 61 | (INIT : initial s) 62 | (INTERM : intermstep xs s s'), 63 | trace_has_at_most_one_violation xs. 64 | 65 | End CFI. 66 | -------------------------------------------------------------------------------- /os/extra/finset.hs: -------------------------------------------------------------------------------- 1 | type Coq_set_type = Data.Set.Set GHC.Base.Any 2 | -- Or should I use my finite-infinite set library from ages ago? 3 | 4 | finsetAbstract :: Prelude.String -> a 5 | finsetAbstract fn = GHC.Stack.errorWithStackTrace (fn Prelude.++ ": finsets are abstract, not finfuns!") 6 | 7 | finsetFinite :: Prelude.String -> a 8 | finsetFinite fn = GHC.Stack.errorWithStackTrace (fn Prelude.++ ": finsets are finite!") 9 | 10 | -- Interestingly 'withFintypeOrd' does not typecheck if (a) eta-expanded, or (b) 11 | -- implemented as 'withFintypeOrd''. WTF‽ 12 | 13 | withFintypeOrd :: Fintype.Finite__Coq_type -> (Prelude.Ord GHC.Base.Any => a) -> a 14 | withFintypeOrd ft = 15 | Data.Reflection.Constraint.providing 16 | (Data.Reflection.Constraint.Ord 17 | (unsafeCoerce (Eqtype.compare_op (Fintype._Finite__eqType ft)))) 18 | -- 'unsafeCoerce' takes us from '()' to 'Any' 19 | 20 | withFintypeOrd' :: (Prelude.Ord GHC.Base.Any => a) -> Fintype.Finite__Coq_type -> a 21 | withFintypeOrd' = Prelude.flip withFintypeOrd 22 | 23 | unitAny :: () -> GHC.Base.Any 24 | unitAny = unsafeCoerce 25 | 26 | anyUnit :: GHC.Base.Any -> () 27 | anyUnit = unsafeCoerce 28 | 29 | nestedSet :: Data.Set.Set GHC.Base.Any -> Data.Set.Set (Data.Set.Set GHC.Base.Any) 30 | nestedSet = unsafeCoerce 31 | 32 | flattenedSet :: Data.Set.Set (Data.Set.Set GHC.Base.Any) -> Data.Set.Set GHC.Base.Any 33 | flattenedSet = unsafeCoerce 34 | 35 | forgetToCoqSet :: Data.Set.Set a -> Data.Set.Set GHC.Base.Any 36 | forgetToCoqSet = unsafeCoerce 37 | 38 | -- This implementation is due to Dan Burton's answer to MarcoS's StackOverflow 39 | -- question "why Data.Set has no powerset function?" [sic], available at 40 | -- http://stackoverflow.com/a/6429301/237428 41 | setPowerset :: Prelude.Ord a => Data.Set.Set a -> Data.Set.Set (Data.Set.Set a) 42 | setPowerset s 43 | | Data.Set.null s = Data.Set.singleton Data.Set.empty 44 | | Prelude.otherwise = Data.Set.map (Data.Set.insert x) ps' `Data.Set.union` ps' 45 | where (x, s') = Data.Set.deleteFindMin s 46 | ps' = setPowerset s' 47 | -------------------------------------------------------------------------------- /memory_safety/propertyS.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import 2 | ssreflect ssrfun ssrbool ssrnat seq eqtype fintype. 3 | From extructures Require Import ord fset fmap fperm. 4 | From CoqUtils Require Import word nominal. 5 | 6 | Require Import lib.utils lib.fmap_utils common.types symbolic.symbolic symbolic.exec. 7 | Require Import memory_safety.property memory_safety.symbolic memory_safety.abstract. 8 | Require Import memory_safety.refinementAS. 9 | Require Import memory_safety.classes memory_safety.executable memory_safety.propertyA. 10 | 11 | Set Implicit Arguments. 12 | Unset Strict Implicit. 13 | Unset Printing Implicit Defensive. 14 | 15 | Section MemorySafety. 16 | 17 | Local Open Scope fset_scope. 18 | 19 | Import Abstract. 20 | 21 | Variable mt : machine_types. 22 | Variable ops : machine_ops mt. 23 | Variable sr : syscall_regs mt. 24 | Variable addrs : memory_syscall_addrs mt. 25 | 26 | Local Notation sstate := (@Symbolic.state mt (Sym.sym_memory_safety mt)). 27 | Local Notation sstepf := 28 | (@stepf _ ops (Sym.sym_memory_safety mt) (@Sym.memsafe_syscalls _ ops _ addrs)). 29 | Local Notation astate := (Abstract.state mt). 30 | Local Notation astepf := (AbstractE.step ops _ addrs). 31 | 32 | Lemma noninterference sst1 sst1' sst2 sst2' mi1 mi2 ast m1 m2 pm n : 33 | stepn sstepf n sst1 = Some sst1' -> 34 | stepn sstepf n sst2 = Some sst2' -> 35 | refine_state mi1 (add_mem m1 ast) sst1 -> 36 | refine_state mi2 (add_mem m2 (rename pm ast)) sst2 -> 37 | fdisjoint (names ast) (domm m1) -> 38 | fdisjoint (names (rename pm ast)) (domm m2) -> 39 | exists ast' pm' mi1' mi2', 40 | [/\ refine_state mi1' (add_mem m1 ast') sst1', 41 | refine_state mi2' (add_mem m2 (rename pm' ast')) sst2', 42 | fdisjoint (names ast') (domm m1) & 43 | fdisjoint (names (rename pm' ast')) (domm m2) ]. 44 | Proof. 45 | move=> ex1 ex2 ref1 ref2 dis1 dis2. 46 | have [mi1' [ast1' [ex1' ref1']]] := refinement ref1 ex1. 47 | have [mi2' [ast2' [ex2' ref2']]] := refinement ref2 ex2. 48 | have := noninterference ops sr addrs n dis1 dis2. 49 | rewrite ex1' ex2'. 50 | case=> pm' [ast' [e1 dis1' e2 dis2']]. 51 | exists ast', pm', mi1', mi2'; split=> //. 52 | by rewrite -e1. 53 | by rewrite -e2. 54 | Qed. 55 | 56 | End MemorySafety. 57 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Postprocess (fixExtractedCode, fixExtractedCodeDirectory) where 4 | 5 | import Control.Monad 6 | import Data.Monoid 7 | 8 | import Data.Char 9 | import Data.List 10 | 11 | import qualified Data.Set as S 12 | 13 | import Data.Text (Text) 14 | import qualified Data.Text as T 15 | import qualified Data.Text.IO as T 16 | 17 | import System.FilePath 18 | import System.Directory 19 | 20 | import Postprocess.Util.Monoid 21 | 22 | import Postprocess.Processor 23 | import Postprocess.FileStructure 24 | import Postprocess.Imports 25 | import Postprocess.Constraints 26 | import Postprocess.Clean 27 | 28 | fixExtractedCode :: Maybe Text -> [Text] -> Processor 29 | fixExtractedCode thisModule extraBody doc = 30 | let (pre, imps, body) = collectPreambleImportsBody extraBody . changeReservedWords $ deCPP doc 31 | (pre',constraints) = partitionConstraints $ "{-# OPTIONS_GHC -w #-}" : fixOptions pre 32 | body' = addConstraints constraints body 33 | neededImps = maybe id S.delete thisModule $ getReferencedModules body' S.\\ getImportedModules imps 34 | imps' = imps ++?? map ("import qualified " <>) (S.toList neededImps) 35 | in pre' ++ imps' ++ body' 36 | 37 | fixExtractedCodeDirectory :: FilePath -> FilePath -> Maybe FilePath -> IO () 38 | fixExtractedCodeDirectory from to mExtra = do 39 | hsFiles <- filter (".hs" `isSuffixOf`) <$> getDirectoryContents from 40 | createDirectoryIfMissing True to 41 | forM_ hsFiles $ \file -> do 42 | let fromFile = from file 43 | toFile = to case file of c : cs -> toUpper c : cs ; "" -> "" 44 | moduleName = T.pack $ takeBaseName toFile 45 | putStrLn $ "Processing file `" ++ fromFile ++ "' to `" ++ toFile ++ "'" 46 | extra <- case mExtra of 47 | Just extra -> do let extraFile = extra file 48 | exists <- doesFileExist $ extra file 49 | if exists 50 | then T.lines <$> T.readFile extraFile 51 | else pure [] 52 | Nothing -> pure [] 53 | runReplacingFile fromFile toFile $ fixExtractedCode (Just moduleName) extra 54 | -------------------------------------------------------------------------------- /os/extra/concrete.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | deriving instance Prelude.Eq Concrete__Coq_mvec 4 | deriving instance Prelude.Ord Concrete__Coq_mvec 5 | 6 | deriving instance Prelude.Eq Concrete__Coq_rvec 7 | deriving instance Prelude.Ord Concrete__Coq_rvec 8 | 9 | _Exports__state_cmp :: Types.Coq_machine_types -> 10 | Concrete__Coq_state -> Concrete__Coq_state -> Prelude.Ordering 11 | _Exports__state_cmp mt s1 s2 = 12 | Data.Monoid.mconcat 13 | [ Eqtype.compare_op 14 | (Partmap._PartMap__Exports__partmap_eqType 15 | (Word.word_ordType (Types.word_size mt)) 16 | (Types.atom_eqType 17 | (Word.word_eqType (Types.word_size mt)) 18 | (Word.word_eqType (Types.word_size mt)))) 19 | (unsafeCoerce (_Concrete__mem mt s1)) 20 | (unsafeCoerce (_Concrete__mem mt s2)) 21 | , Eqtype.compare_op 22 | (Partmap._PartMap__Exports__partmap_eqType 23 | (Word.word_ordType (Types.reg_field_size mt)) 24 | (Types.atom_eqType 25 | (Word.word_eqType (Types.word_size mt)) 26 | (Word.word_eqType (Types.word_size mt)))) 27 | (unsafeCoerce (_Concrete__regs mt s1)) 28 | (unsafeCoerce (_Concrete__regs mt s2)) 29 | , Eqtype.compare_op 30 | (Partmap._PartMap__Exports__partmap_eqType 31 | (_Concrete__mvec_ordType mt) 32 | (_Concrete__rvec_eqType mt)) 33 | (unsafeCoerce (_Concrete__cache mt s1)) 34 | (unsafeCoerce (_Concrete__cache mt s2)) 35 | , Eqtype.compare_op 36 | (Types.atom_eqType 37 | (Word.word_eqType (Types.word_size mt)) 38 | (Word.word_eqType (Types.word_size mt))) 39 | (unsafeCoerce (_Concrete__pc mt s1)) 40 | (unsafeCoerce (_Concrete__pc mt s2)) 41 | , Eqtype.compare_op 42 | (Types.atom_eqType 43 | (Word.word_eqType (Types.word_size mt)) 44 | (Word.word_eqType (Types.word_size mt))) 45 | (unsafeCoerce (_Concrete__epc mt s1)) 46 | (unsafeCoerce (_Concrete__epc mt s2)) ] 47 | 48 | -- `Show' instances 49 | deriving instance Prelude.Show Concrete__Coq_mvec 50 | deriving instance Prelude.Show Concrete__Coq_rvec 51 | deriving instance Prelude.Show Concrete__Coq_mvec_part 52 | deriving instance Prelude.Show Concrete__CTMask 53 | deriving instance Prelude.Show Concrete__Coq_state 54 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Postprocess/Constraints.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Postprocess.Constraints ( 4 | ExtraConstraint(..), 5 | parseConstraint, partitionConstraints, addConstraints 6 | ) where 7 | 8 | import Control.Arrow 9 | import Control.Monad 10 | import Data.Monoid 11 | 12 | import Data.Char 13 | import Data.Maybe 14 | import Data.Either 15 | 16 | import Data.Map (Map) 17 | import qualified Data.Map as M 18 | 19 | import Data.Text (Text) 20 | import qualified Data.Text as T 21 | import qualified Data.Text.Read as T 22 | 23 | import Postprocess.Util.List 24 | import Postprocess.Util.Haskell 25 | 26 | import Postprocess.Processor 27 | 28 | data ExtraConstraint = ExtraConstraint { constraintName :: Text 29 | , constraintTypeVariableIndex :: Integer } 30 | deriving (Eq, Ord, Show, Read) 31 | 32 | parseConstraint :: Text -> Maybe (Text,[ExtraConstraint]) 33 | parseConstraint line = do 34 | [val, conDesc] <- map T.strip . T.splitOn "::" 35 | <$> (T.stripPrefix "{-# POSTPROCESS CONSTRAINT" 36 | =<< T.stripSuffix "#-}" (T.strip line)) 37 | constraints <- forM (map T.words $ T.splitOn "," conDesc) $ \conWords -> do 38 | [constraint,tvIxStr] <- pure conWords 39 | guard $ T.all isHaskellQualidChar constraint 40 | case T.decimal tvIxStr of 41 | Right (tvIx,"") -> pure $ ExtraConstraint constraint tvIx 42 | _ -> mzero 43 | pure (val, constraints) 44 | 45 | partitionConstraints :: Document -> (Document, Map Text [ExtraConstraint]) 46 | partitionConstraints = second M.fromList . partitionEithers 47 | . map (\line -> maybe (Left line) Right $ parseConstraint line) 48 | 49 | addConstraints :: Map Text [ExtraConstraint] -> Processor 50 | addConstraints valConstraints = map $ \line -> fromMaybe line $ do 51 | [val, ty] <- pure $ T.splitOn " :: " line 52 | guard . not $ "=>" `T.isInfixOf` ty 53 | let tvs = filter (maybe False (isLower . fst) . T.uncons) 54 | . T.words 55 | $ T.map (\c -> if isHaskellQualidChar c then c else ' ') ty 56 | constrain (ExtraConstraint c ix) = ((c <> " ") <>) <$> (tvs ?? ix) 57 | constraints <- mapM constrain =<< M.lookup val valConstraints 58 | pure $ T.concat [val, " :: (", T.intercalate ", " constraints, ") => ", ty] 59 | -------------------------------------------------------------------------------- /lib/ssr_set_utils.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import 2 | ssreflect ssrfun ssrbool ssrnat eqtype ssrnat seq bigop fintype finset. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | Set Bullet Behavior "Strict Subproofs". 9 | 10 | (* For extraction -- `enum' is super slow when working with large `finType`s, 11 | but because it's implemented on top of `enum_mem', we can't just rewrite it 12 | for all sets. *) 13 | Definition enum_set {T : finType} (s : {set T}) : seq T := enum s. 14 | (* Can't be eta-reduced -- `enum` is a weird abbreviation *) 15 | 16 | Theorem common_not_disjoint (T : finType) (x : T) (A B : {set T}) : 17 | x \in A -> x \in B -> ~~ [disjoint A & B]. 18 | Proof. 19 | move=> IN_A IN_B. 20 | rewrite -setI_eq0; apply/set0Pn; exists x. 21 | by rewrite in_setI; apply/andP. 22 | Qed. 23 | Arguments common_not_disjoint [T] x [A B] _ _. 24 | 25 | Lemma bigcup_seq_in (S : eqType) (T : finType) 26 | (t : T) (a : S) (A : seq S) (F : S -> {set T}) : 27 | a \in A -> t \in F a -> t \in \bigcup_(x <- A) F x. 28 | Proof. by move=> IN_a IN_t; rewrite (big_rem a) //= inE IN_t. Qed. 29 | Arguments bigcup_seq_in [S T t] a [A F] _ _. 30 | 31 | Theorem bigcup_seqP (S : eqType) (T : finType) 32 | (t : T) (A : seq S) (F : S -> {set T}) : 33 | reflect (exists a, a \in A /\ t \in F a) (t \in \bigcup_(x <- A) F x). 34 | Proof. 35 | have [IN | NIN] := boolP (t \in \bigcup_(x <- A) F x); constructor. 36 | - elim: A IN => [| a A IH IN]; first by rewrite big_nil inE. 37 | rewrite big_cons in_setU in IN. 38 | case/orP: IN => [HERE | THERE]. 39 | + by exists a; rewrite inE eq_refl. 40 | + case/IH: THERE => [a' [IN_A IN_Fa']]. 41 | by exists a'; rewrite inE IN_A orbT. 42 | - move=> [a [IN_a IN_t]]; case/negP: NIN. 43 | elim: A IN_a => [// | a' A IH IN_a]. 44 | rewrite big_cons inE; rewrite inE in IN_a; apply/orP. 45 | case/orP: IN_a => [/eqP EQ | IN_a]; first subst a'. 46 | + by left. 47 | + by right; apply IH. 48 | Qed. 49 | 50 | Theorem subsetDU (T : finType) (A B : {set T}) : 51 | B \subset A -> A = A :\: B :|: B. 52 | Proof. by move=> /setIidPr SUBSET; rewrite -{1}(setID A B) SUBSET setUC. Qed. 53 | 54 | Theorem forall_subset (T : finType) (A B : {set T}) (P : T -> bool) : 55 | A \subset B -> [forall x in B, P x] -> [forall x in A, P x]. 56 | Proof. 57 | by move=> SUB ALL; apply/forall_inP => x IN; 58 | apply (elimT forall_inP ALL); apply (elimT subsetP SUB). 59 | Qed. 60 | 61 | Theorem forall_impl (T : finType) (A : {set T}) (P Q : T -> bool) : 62 | (forall x, P x -> Q x) -> [forall x in A, P x] -> [forall x in A, Q x]. 63 | Proof. 64 | by move=> IMPL ALL; apply/forall_inP => x IN; 65 | apply IMPL; apply (elimT forall_inP ALL). 66 | Qed. 67 | -------------------------------------------------------------------------------- /os/haskell/Haskell/Util/Lifts.hs: -------------------------------------------------------------------------------- 1 | module Haskell.Util.Lifts ( 2 | liftListenStrictWriter, liftPassStrictWriter, 3 | liftListenLazyWriter, liftPassLazyWriter, 4 | liftListenStrictRWS, liftPassStrictRWS, 5 | liftListenLazyRWS, liftPassLazyRWS, 6 | liftCatchError, 7 | liftCatchEither 8 | ) where 9 | 10 | import Control.Monad.Writer.Strict as StrictWriter 11 | import Control.Monad.Writer.Lazy as LazyWriter 12 | import Control.Monad.RWS.Strict as StrictRWS 13 | import Control.Monad.RWS.Lazy as LazyRWS 14 | import Control.Monad.Error 15 | import Control.Monad.Trans.Either 16 | import Control.Monad.Signatures 17 | 18 | -- Lift monadic operations through their native monad 19 | 20 | liftListenStrictWriter :: Monad m => Listen w1 m (a,w2) -> Listen w1 (StrictWriter.WriterT w2 m) a 21 | liftListenStrictWriter listen' m = StrictWriter.WriterT $ do 22 | ((a,w2),w1) <- listen' $ StrictWriter.runWriterT m 23 | return ((a,w1),w2) 24 | 25 | liftPassStrictWriter :: Monad m => Pass w1 m (a,w2) -> Pass w1 (StrictWriter.WriterT w2 m) a 26 | liftPassStrictWriter pass' m = StrictWriter.WriterT . pass' $ do 27 | ((a,f),w2) <- StrictWriter.runWriterT m 28 | return ((a,w2),f) 29 | 30 | liftListenLazyWriter :: Monad m => Listen w1 m (a,w2) -> Listen w1 (LazyWriter.WriterT w2 m) a 31 | liftListenLazyWriter listen' m = LazyWriter.WriterT $ do 32 | ~((a,w2),w1) <- listen' $ LazyWriter.runWriterT m 33 | return ((a,w1),w2) 34 | 35 | liftPassLazyWriter :: Monad m => Pass w1 m (a,w2) -> Pass w1 (LazyWriter.WriterT w2 m) a 36 | liftPassLazyWriter pass' m = LazyWriter.WriterT . pass' $ do 37 | ~((a,f),w2) <- LazyWriter.runWriterT m 38 | return ((a,w2),f) 39 | 40 | liftListenStrictRWS :: Monad m => Listen w1 m (a,s,w2) -> Listen w1 (StrictRWS.RWST r w2 s m) a 41 | liftListenStrictRWS listen' m = StrictRWS.RWST $ \r s -> do 42 | ((a,s,w2),w1) <- listen' $ StrictRWS.runRWST m r s 43 | return ((a,w1),s,w2) 44 | 45 | liftPassStrictRWS :: Monad m => Pass w1 m (a,s,w2) -> Pass w1 (StrictRWS.RWST r w2 s m) a 46 | liftPassStrictRWS pass' m = StrictRWS.RWST $ \r s -> pass' $ do 47 | ((a,f),s,w2) <- StrictRWS.runRWST m r s 48 | return ((a,s,w2),f) 49 | 50 | liftListenLazyRWS :: Monad m => Listen w1 m (a,s,w2) -> Listen w1 (LazyRWS.RWST r w2 s m) a 51 | liftListenLazyRWS listen' m = LazyRWS.RWST $ \r s -> do 52 | ~((a,s,w2),w1) <- listen' $ LazyRWS.runRWST m r s 53 | return ((a,w1),s,w2) 54 | 55 | liftPassLazyRWS :: Monad m => Pass w1 m (a,s,w2) -> Pass w1 (LazyRWS.RWST r w2 s m) a 56 | liftPassLazyRWS pass' m = LazyRWS.RWST $ \r s -> pass' $ do 57 | ~((a,f),s,w2) <- LazyRWS.runRWST m r s 58 | return ((a,s,w2),f) 59 | 60 | liftCatchError :: Monad m => Catch e1 m (Either e2 a) -> Catch e1 (ErrorT e2 m) a 61 | liftCatchError catch' m h = ErrorT $ runErrorT m `catch'` (runErrorT . h) 62 | 63 | liftCatchEither :: Monad m => Catch e1 m (Either e2 a) -> Catch e1 (EitherT e2 m) a 64 | liftCatchEither catch' m h = EitherT $ runEitherT m `catch'` (runEitherT . h) 65 | 66 | -- I'm not writing liftCallCCCont because I don't hate myself 67 | -------------------------------------------------------------------------------- /os/extra/symbolic0.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | 3 | deriving instance Prelude.Eq Sym__Coq_pc_tag 4 | deriving instance Prelude.Ord Sym__Coq_pc_tag 5 | 6 | _Sym__Exports__data_tag_cmp :: Types.Coq_machine_types -> Sym__Coq_data_tag -> 7 | Sym__Coq_data_tag -> Prelude.Ordering 8 | _Sym__Exports__data_tag_cmp mt (Sym__DATA c1 i1 w1) (Sym__DATA c2 i2 w2) = 9 | Eqtype.compare_op (Word.word_eqType (Types.word_size mt)) 10 | (unsafeCoerce c1) (unsafeCoerce c2) 11 | Data.Monoid.<> 12 | Eqtype.compare_op (Finset.set_of_eqType (Word.word_finType (Types.word_size mt))) 13 | (unsafeCoerce i1) (unsafeCoerce i2) 14 | Data.Monoid.<> 15 | Eqtype.compare_op (Finset.set_of_eqType (Word.word_finType (Types.word_size mt))) 16 | (unsafeCoerce w1) (unsafeCoerce w2) 17 | 18 | _Sym__compartmentalization_internal_cmp :: Types.Coq_machine_types -> 19 | Sym__Coq_compartmentalization_internal -> 20 | Sym__Coq_compartmentalization_internal -> 21 | Prelude.Ordering 22 | _Sym__compartmentalization_internal_cmp mt i1 i2 = 23 | Eqtype.compare_op (Word.word_eqType (Types.word_size mt)) 24 | (unsafeCoerce (_Sym__next_id mt i1)) 25 | (unsafeCoerce (_Sym__next_id mt i2)) 26 | Data.Monoid.<> 27 | Eqtype.compare_op (_Sym__Exports__data_tag_eqType mt) 28 | (unsafeCoerce (_Sym__isolate_tag mt i1)) 29 | (unsafeCoerce (_Sym__isolate_tag mt i2)) 30 | Data.Monoid.<> 31 | Eqtype.compare_op (_Sym__Exports__data_tag_eqType mt) 32 | (unsafeCoerce (_Sym__add_to_jump_targets_tag mt i1)) 33 | (unsafeCoerce (_Sym__add_to_jump_targets_tag mt i2)) 34 | Data.Monoid.<> 35 | Eqtype.compare_op (_Sym__Exports__data_tag_eqType mt) 36 | (unsafeCoerce (_Sym__add_to_store_targets_tag mt i1)) 37 | (unsafeCoerce (_Sym__add_to_store_targets_tag mt i2)) 38 | 39 | -- `Show' instances 40 | deriving instance Prelude.Show Sym__Coq_pc_tag 41 | deriving instance Prelude.Show Sym__Coq_compartmentalization_internal 42 | 43 | instance Prelude.Show Sym__Coq_data_tag where 44 | showsPrec p (Sym__DATA c ii ww) = Prelude.showParen (p Prelude.>= 11) 45 | $ Prelude.showString "Sym__DATA " 46 | . Prelude.showsPrec 11 c 47 | . Prelude.showChar ' ' 48 | . Prelude.showsPrec 11 (wordSet ii) 49 | . Prelude.showChar ' ' 50 | . Prelude.showsPrec 11 (wordSet ww) 51 | where 52 | wordSet :: Finset.Coq_set_of -> Data.Set.Set Types.Coq_mword 53 | wordSet = unsafeCoerce 54 | 55 | (.) = (Prelude..) 56 | infixr 9 . 57 | {-# INLINABLE (.) #-} 58 | 59 | ($) = (Prelude.$) 60 | infixr 0 $ 61 | {-# INLINABLE ($) #-} 62 | -------------------------------------------------------------------------------- /os/haskell/Haskell/Util.hs: -------------------------------------------------------------------------------- 1 | module Haskell.Util where 2 | 3 | import Control.Applicative 4 | import Control.Monad 5 | import Data.Maybe 6 | import Data.Data 7 | import Data.List 8 | 9 | (??) :: (Eq i, Integral i) => [a] -> i -> Maybe a 10 | [] ?? _ = Nothing 11 | (x:xs) ?? i = case i `compare` 0 of 12 | LT -> Nothing 13 | EQ -> Just x 14 | GT -> xs ?? (i-1) 15 | 16 | -- showSigned 1 == "+1" 17 | -- showSigned 0 == "0" 18 | -- showSigned (-1) == "-1" 19 | showSigned :: (Num a, Ord a, Show a) => a -> String 20 | showSigned x | x > 0 = '+' : show x 21 | | otherwise = show x 22 | 23 | gmapDeepT :: (Typeable a, Data b) => (a -> a) -> b -> b 24 | gmapDeepT f = gmapT $ fromMaybe <$> gmapDeepT f <*> (cast . f <=< cast) 25 | 26 | gmapDeepM :: (Typeable a, Data b, Monad m) => (a -> m a) -> b -> m b 27 | gmapDeepM f = gmapM $ fromMaybe <$$> gmapDeepM f <**> use f where 28 | use f = maybe (return Nothing) (liftM cast) . fmap f . cast 29 | 30 | (<$$>) :: (Functor f, Monad g) => (a -> b) -> f (g a) -> f (g b) 31 | (<$$>) = fmap . liftM 32 | infixl 4 <$$> 33 | 34 | (<**>) :: (Applicative f, Monad g) => f (g (a -> b)) -> f (g a) -> f (g b) 35 | (<**>) = liftA2 ap 36 | infixl 4 <**> 37 | 38 | data Alignment = AlignLeft 39 | | AlignRight 40 | deriving (Eq, Ord, Enum, Bounded, Show, Read) 41 | -- AlignCenter is too hard :-) 42 | 43 | -- `pad' and friends require finite lengths 44 | pad :: Integral i => Alignment -> a -> i -> [a] -> [a] 45 | pad a p n xs = let ps = genericReplicate (n - genericLength xs) p 46 | in case a of 47 | AlignLeft -> xs ++ ps 48 | AlignRight -> ps ++ xs 49 | 50 | padToMatch :: Alignment -> a -> [[a]] -> [[a]] 51 | padToMatch a p xss = map (pad a p . maximum $ 0 : map length xss) xss 52 | 53 | alignColumns :: [(Alignment,a)] -> [[[a]]] -> [[[a]]] 54 | alignColumns alignments table = 55 | transpose . zipWith (uncurry padToMatch) alignments $ transpose table 56 | 57 | -- Why are liftA4 and liftA5 missing? 58 | liftA4 :: Applicative f => (a1 -> a2 -> a3 -> a4 -> r) -> f a1 -> f a2 -> f a3 -> f a4 -> f r 59 | liftA4 f a1 a2 a3 a4 = f <$> a1 <*> a2 <*> a3 <*> a4 60 | 61 | liftA5 :: Applicative f => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> f a1 -> f a2 -> f a3 -> f a4 -> f a5 -> f r 62 | liftA5 f a1 a2 a3 a4 a5 = f <$> a1 <*> a2 <*> a3 <*> a4 <*> a5 63 | 64 | bind1 :: Monad m => (a1 -> m r) -> m a1 -> m r 65 | bind1 = (=<<) 66 | 67 | bind2 :: Monad m => (a1 -> a2 -> m r) -> m a1 -> m a2 -> m r 68 | bind2 f m1 m2 = do 69 | a1 <- m1 70 | a2 <- m2 71 | f a1 a2 72 | 73 | bind3 :: Monad m => (a1 -> a2 -> a3 -> m r) -> m a1 -> m a2 -> m a3 -> m r 74 | bind3 f m1 m2 m3 = do 75 | a1 <- m1 76 | a2 <- m2 77 | a3 <- m3 78 | f a1 a2 a3 79 | 80 | bind4 :: Monad m => (a1 -> a2 -> a3 -> a4 -> m r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r 81 | bind4 f m1 m2 m3 m4 = do 82 | a1 <- m1 83 | a2 <- m2 84 | a3 <- m3 85 | a4 <- m4 86 | f a1 a2 a3 a4 87 | 88 | bind5 :: Monad m => (a1 -> a2 -> a3 -> a4 -> a5 -> m r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r 89 | bind5 f m1 m2 m3 m4 m5 = do 90 | a1 <- m1 91 | a2 <- m2 92 | a3 <- m3 93 | a4 <- m4 94 | a5 <- m5 95 | f a1 a2 a3 a4 a5 96 | -------------------------------------------------------------------------------- /ifc/noninterferenceS.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import 2 | ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finfun. 3 | From extructures Require Import ord fset fmap. 4 | From CoqUtils Require Import hseq word. 5 | From MicroPolicies Require Import 6 | lib.utils lib.fmap_utils common.types symbolic.symbolic symbolic.exec 7 | ifc.labels ifc.common ifc.symbolic ifc.abstract ifc.noninterference ifc.refinementSA. 8 | 9 | Set Implicit Arguments. 10 | Unset Strict Implicit. 11 | Unset Printing Implicit Defensive. 12 | 13 | Section Noninterference. 14 | 15 | Import DoNotation. 16 | 17 | Variable L : labType. 18 | Variable mt : machine_types. 19 | Variable mops : machine_ops mt. 20 | Context {sregs : syscall_regs mt}. 21 | Context {addrs : ifc_addrs mt}. 22 | 23 | Local Notation word := (mword mt). 24 | Local Notation d_atom := (atom word L). 25 | 26 | Local Notation sstate := (@Symbolic.state mt (sym_ifc L mt)). 27 | Local Notation sstep := 28 | (@stepf _ _ _ (@ifc_syscalls L mt mops sregs addrs)). 29 | Local Notation strace := 30 | (@symbolic.trace _ _ _ sregs addrs). 31 | Local Notation astate := (ifc.abstract.state L mt). 32 | Local Notation astep := (@step L mt mops sregs addrs). 33 | Local Notation atrace := 34 | (@abstract.trace _ _ _ sregs addrs). 35 | Implicit Types (st : sstate). 36 | 37 | Local Open Scope label_scope. 38 | 39 | Inductive s_indist rs st1 st2 := 40 | | SIndist of taga (Symbolic.pc st1) ⊑ rs 41 | & Symbolic.pc st1 = Symbolic.pc st2 42 | & pointwise (indist taga rs) 43 | (Symbolic.regs st1) (Symbolic.regs st2) 44 | & pointwise (indist (fun t => 45 | if taga t is MemData rl 46 | then rl 47 | else ⊥) rs) 48 | (Symbolic.mem st1) (Symbolic.mem st2) 49 | & Symbolic.internal st1 = IntIFC [::] [::] 50 | & Symbolic.internal st2 = IntIFC [::] [::]. 51 | 52 | Theorem noninterference rs st1 st2 n1 n2 : 53 | s_indist rs st1 st2 -> 54 | indist_seq_prefix eq 55 | [seq x <- strace n1 st1 | taga x ⊑ rs] 56 | [seq x <- strace n2 st2 | taga x ⊑ rs]. 57 | Proof. 58 | move=> ind. 59 | have {ind} ind: 60 | noninterference.s_indist rs (abs_of_sym mops st1) (abs_of_sym mops st2). 61 | case: ind => lo_pc e_pc ind_r ind_m int01 int02. 62 | rewrite /abs_of_sym; apply: SIndistLow=> //=. 63 | move=> ptr; rewrite !mapmE /=. 64 | move: (ind_m ptr). 65 | case: (Symbolic.mem st1 ptr) => [[v1 l1]|] //=; 66 | case: (Symbolic.mem st2 ptr) => [[v2 l2]|] //=. 67 | rewrite /indist /=. 68 | case: l1 l2 => [|l1] [|l2] //=; rewrite ?botP ?orbT ?eqxx /= => /eqP //. 69 | by move => [<-]. 70 | by rewrite int01 int02 /=. 71 | have [t1 et1] : exists t, atrace n1 (abs_of_sym mops st1) = strace n1 st1 ++ t. 72 | exact/refinement/abs_of_symP. 73 | have [t2 et2] : exists t, atrace n2 (abs_of_sym mops st2) = strace n2 st2 ++ t. 74 | exact/refinement/abs_of_symP. 75 | have: 76 | indist_seq_prefix eq 77 | [seq x <- atrace n1 (abs_of_sym mops st1) | taga x ⊑ rs] 78 | [seq x <- atrace n2 (abs_of_sym mops st2) | taga x ⊑ rs]. 79 | exact: noninterference ind. 80 | rewrite et1 et2 !filter_cat. 81 | exact: indist_seq_prefix_sub. 82 | Qed. 83 | 84 | End Noninterference. 85 | -------------------------------------------------------------------------------- /common/segment.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import 2 | ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype div ssrint ssralg 3 | intdiv. 4 | From extructures Require Import ord fmap. 5 | From CoqUtils Require Import word. 6 | 7 | Require Import lib.utils common.types. 8 | 9 | Set Implicit Arguments. 10 | Unset Strict Implicit. 11 | Unset Printing Implicit Defensive. 12 | 13 | Section Relocation. 14 | 15 | Context {mt : machine_types} 16 | {ops : machine_ops mt}. 17 | 18 | (* The type of relocatable memory segments. The first nat specifies 19 | the segment's size. The argument type specifies what kind of 20 | relocation information is needed (e.g., nothing for constant 21 | segments; just one word for relocatable code; a pair of words for 22 | relocatable code that also needs access to a shared data area). 23 | 24 | TODO: One issue is that we need the resulting list to always be of 25 | the specified size, but the type does not demand this at the 26 | moment. One way to deal with this is to add a proof component that 27 | certifies that the resulting list always has the specified length. 28 | Is there a better way? (This seems not too bad: our structured 29 | code combinators can build these certificates pretty easily.) *) 30 | 31 | Definition relocatable_segment := 32 | fun Args => fun Cell => (nat * (mword mt -> Args -> seq Cell))%type. 33 | 34 | Definition empty_relocatable_segment (Args Cell : Type) : relocatable_segment Args Cell := 35 | (0, fun (base : mword mt) (rest : Args) => [::]). 36 | 37 | (* Concatenates list of relocatable segments into one, returning a 38 | list of offsets (relative to the base address). *) 39 | Definition concat_and_measure_relocatable_segments 40 | (Args Cell : Type) 41 | (segs : seq (relocatable_segment Args Cell)) 42 | : relocatable_segment Args Cell * seq nat := 43 | foldl 44 | (fun (p : relocatable_segment Args Cell * seq nat) 45 | (seg : relocatable_segment Args Cell) => 46 | let: (acc,addrs) := p in 47 | let (l1,gen1) := acc in 48 | let (l2,gen2) := seg in 49 | let gen := fun (base : mword mt) (rest : Args) => 50 | gen1 base rest 51 | ++ gen2 (addw base (as_word l1)) rest in 52 | let newseg := (l1+l2, gen) in 53 | (newseg, addrs ++ [:: l1])) 54 | (empty_relocatable_segment _ _, [::]) 55 | segs. 56 | 57 | Definition concat_relocatable_segments 58 | (Args Cell : Type) 59 | (segs : seq (relocatable_segment Args Cell)) 60 | : relocatable_segment Args Cell := 61 | fst (concat_and_measure_relocatable_segments segs). 62 | 63 | Definition map_relocatable_segment 64 | (Args Cell Cell' : Type) 65 | (f : Cell -> Cell') 66 | (seg : relocatable_segment Args Cell) 67 | : relocatable_segment Args Cell' := 68 | let (l,gen) := seg in 69 | let gen' := fun (base : mword mt) (rest : Args) => map f (gen base rest) in 70 | (l, gen'). 71 | 72 | Definition relocate_ignore_args 73 | (Args Cell : Type) 74 | (seg : relocatable_segment unit Cell) 75 | : relocatable_segment Args Cell := 76 | let (l,gen) := seg in 77 | let gen' := fun (base : mword mt) (rest : Args) => gen base tt in 78 | (l, gen'). 79 | 80 | End Relocation. 81 | 82 | Ltac current_instr_opcode := 83 | match goal with 84 | | H : decode_instr _ = Some ?instr |- _ => 85 | let op := (eval compute in (opcode_of instr)) in 86 | op 87 | end. 88 | -------------------------------------------------------------------------------- /os/haskell/Haskell/Inspect.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Haskell.Inspect where 3 | 4 | import Data.List 5 | 6 | import Haskell.Util 7 | import Haskell.Types 8 | import Haskell.Word 9 | import Haskell.Machine 10 | import Haskell.Pretty 11 | import Haskell.OS 12 | 13 | import Data.Map (Map) 14 | import qualified Data.Map as M 15 | 16 | inspectWord :: MWord -> Doc 17 | inspectWord w = 18 | let ppp x = parens $ pPrint x -- DMR 19 | s = Signed $ mwordWord w 20 | in case decodeInstr w of 21 | Just i -> i <&> if s < 0 then pPrint (w,s) else ppp w 22 | Nothing -> w <&> if s < 0 then ppp s else empty 23 | 24 | inspectInstr :: MWord -> Doc 25 | inspectInstr w = maybe (pPrint w) pPrint $ decodeInstr w 26 | 27 | inspectAtom :: Pretty t => Atom MWord t -> Doc 28 | inspectAtom (w :@ t) = inspectWord w <&> taggedOp <&> t 29 | 30 | inspectMaybe :: Pretty t => Maybe (Atom MWord t) -> Doc 31 | inspectMaybe = maybe "" inspectAtom 32 | 33 | inspectPieceAtIndex :: (Pretty t, Ord k) 34 | => (s -> Map k (Atom MWord t)) -> s -> k -> Doc 35 | inspectPieceAtIndex f s i = inspectMaybe $ M.lookup i (f s) 36 | 37 | inspectAddr :: State -> MWord -> Doc 38 | inspectAddr = inspectPieceAtIndex mem 39 | 40 | -- No, these next two should use `pPrint' for atoms instead of 41 | -- `inspectAtom`... or should they? ACTUALLY, `inspectAtom` should be 42 | -- cleverer about when to space out the tag... and then there's columning to 43 | -- handle.... 44 | 45 | inspectPC :: State -> Doc 46 | inspectPC = inspectAtom . pc 47 | 48 | inspectReg :: State -> Reg -> Doc 49 | inspectReg = inspectPieceAtIndex regs 50 | 51 | inspectAddrs' :: (MWord -> String) -> State -> [MWord] -> [Doc] 52 | inspectAddrs' ashow s addrs = map (hcat . map text) 53 | $ transpose [ padToMatch AlignRight ' ' addrColumn 54 | , padToMatch AlignLeft ' ' valueColumn 55 | , tagColumn ] 56 | where 57 | atomColumn missing ppp get = 58 | map (\i -> show . maybe missing ppp . fmap get $ M.lookup i (mem s)) addrs 59 | addrColumn = map ((++ ": ") . ashow) addrs 60 | valueColumn = atomColumn "" inspectInstr val 61 | tagColumn = atomColumn empty ((" @" <+>) . pPrint) tag 62 | 63 | inspectAddrs :: State -> [MWord] -> Doc 64 | inspectAddrs = (vcat .) . inspectAddrs' show 65 | 66 | inspectAroundPC' :: (MWord -> String) -> State -> Integer -> [Doc] 67 | inspectAroundPC' ashow s r = 68 | let pcA = toInteger . val $ pc s 69 | maxAddr = toInteger $ if M.null (mem s) then 0 else fst . M.findMax $ mem s 70 | addrs = [mword $ max (pcA - r) 0 .. mword $ min (pcA + r) maxAddr] 71 | in inspectAddrs' 72 | (\i -> (if i == mword pcA 73 | then "[pc] " 74 | else " ") 75 | ++ ashow i) 76 | s 77 | (if null addrs then [mword pcA] else addrs) 78 | 79 | inspectAroundPC :: State -> Integer -> Doc 80 | inspectAroundPC = (vcat .) . inspectAroundPC' show 81 | 82 | inspectRegs :: State -> [Reg] -> Doc 83 | inspectRegs s rs = vcat . map (hcat . map text) 84 | $ transpose [ padToMatch AlignLeft ' ' $ map show rs 85 | , valueColumn ] 86 | where 87 | valueColumn = 88 | map (\i -> show . maybe " " ((" ->" <+>) . pPrint) 89 | . fmap val 90 | $ M.lookup i (regs s)) 91 | rs 92 | 93 | inspectRegFile :: State -> Doc 94 | inspectRegFile = flip inspectRegs [0..userRegMax] 95 | -------------------------------------------------------------------------------- /os/haskell/Haskell/RetypeData/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, TemplateHaskell #-} 2 | module Haskell.RetypeData.TH (retypeData) where 3 | 4 | import Language.Haskell.TH 5 | import Language.Haskell.TH.Syntax 6 | 7 | import Haskell.Util 8 | import Control.Applicative 9 | import Data.Maybe 10 | 11 | import Unsafe.Coerce 12 | 13 | -- Given 14 | -- 15 | -- > data Old = XA | YB Bad Int | XC Good Bad deriving (Eq, Ord) 16 | -- 17 | -- running 18 | -- 19 | -- > retypeData ''Old "New" 20 | -- > Nothing 21 | -- > [(''Bad,''Good)] 22 | -- > (dropWhile (== 'X')) 23 | -- > [''Eq] 24 | -- > "olden" "newen" 25 | -- 26 | -- produces 27 | -- 28 | -- > data New = A | YB Good Int | C Good Good deriving Eq 29 | -- > 30 | -- > olden :: New -> Old 31 | -- > olden = unsafeCoerce 32 | -- > 33 | -- > newen :: Old -> New 34 | -- > newen = unsafeCoerce 35 | -- 36 | -- We can also produce records. Given 37 | -- 38 | -- > data Old = XRec Good Int Bad deriving (Eq, Ord) 39 | -- 40 | -- running 41 | -- 42 | -- > retypeData ''Old "New" 43 | -- > (Just ["good", "int", "bad"]) 44 | -- > [(''Bad,''Good)] 45 | -- > (dropWhile (== 'X')) 46 | -- > [''Eq] 47 | -- > "olden" "newen" 48 | -- 49 | -- produces 50 | -- 51 | -- > data New = Rec {good :: Good, int :: Int, bad :: Bad} deriving Eq 52 | -- > 53 | -- > olden :: New -> Old 54 | -- > olden = unsafeCoerce 55 | -- > 56 | -- > newen :: Old -> New 57 | -- > newen = unsafeCoerce 58 | 59 | retypeData :: Name -> String -> Maybe [String] 60 | -> [(Name,Name)] -> (String -> String) 61 | -> [Name] 62 | -> String -> String 63 | -> DecsQ 64 | retypeData oldDataType newDataType fieldNames 65 | replacements rename 66 | derivations 67 | toOld fromOld = do 68 | let unqualify name = (<$> reify name) $ \case 69 | DataConI _ _ ty _ | ty == oldDataType -> 70 | mkName . rename $ nameBase name 71 | _ -> 72 | name 73 | TyConI (DataD [] _ [] ctors _) <- reify oldDataType 74 | ctors' <- gmapDeepM (fromMaybe <$> unqualify 75 | <*> fmap pure . (`lookup` replacements)) 76 | ctors 77 | >>= maybe pure convert_to_record fieldNames 78 | let newTypeD = [DataD [] (mkName newDataType) [] ctors' derivations] 79 | 80 | let mkCoercion name from to = 81 | [ SigD name $ ArrowT `AppT` ConT from `AppT` ConT to 82 | , FunD name [Clause [] (NormalB $ VarE 'unsafeCoerce) []] ] 83 | toOldD = mkCoercion (mkName toOld) (mkName newDataType) oldDataType 84 | fromOldD = mkCoercion (mkName fromOld) oldDataType (mkName newDataType) 85 | 86 | return $ newTypeD ++ toOldD ++ fromOldD 87 | 88 | convert_to_record :: [String] -> [Con] -> Q [Con] 89 | convert_to_record fieldNames [NormalC name strictTys] = do 90 | fields <- add_field_names fieldNames strictTys 91 | pure [RecC name fields] 92 | convert_to_record _ _ = 93 | fail $ "retypeDataAsRecord: Cannot process data types unless they have " 94 | ++ "exactly one ordinary (non-infix, non-record, non-existential) " 95 | ++ "constructor" 96 | 97 | add_field_names :: [String] -> [StrictType] -> Q [VarStrictType] 98 | add_field_names [] [] = 99 | pure [] 100 | add_field_names (f:fs) ((s,t):sts) = 101 | ((mkName f,s,t) :) <$> add_field_names fs sts 102 | add_field_names (_:_) [] = 103 | fail "retypeDataAsRecord: Too many field names" 104 | add_field_names [] (_:_) = 105 | fail "retypeDataAsRecord: Not enough field names" 106 | -------------------------------------------------------------------------------- /os/haskell/Toplevel.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 2 | module Toplevel where 3 | 4 | import qualified Action 5 | import qualified Automorphism 6 | import qualified Bigop 7 | import qualified BinNat 8 | import qualified BinNums 9 | import qualified BinPos 10 | import qualified Binomial 11 | import qualified Bool 12 | import qualified Choice 13 | import qualified Common 14 | import qualified Concrete 15 | import qualified Datatypes 16 | import qualified Div 17 | import qualified Eqtype 18 | import qualified Exec 19 | import qualified Exec0 20 | import qualified Fault_handler 21 | import qualified Finalg 22 | import qualified Finfun 23 | import qualified Fingroup 24 | import qualified Finset 25 | import qualified Fintype 26 | import qualified Fperm 27 | import qualified Fset 28 | import qualified Hseq 29 | import qualified Int_0 30 | import qualified Int_32 31 | import qualified Intdiv 32 | import qualified Isolate_sets 33 | import qualified Logic 34 | import qualified Matrix 35 | import qualified Morphism 36 | import qualified Mxalgebra 37 | import qualified Nominal 38 | import qualified Ord 39 | import qualified Os 40 | import qualified Partmap 41 | import qualified Path 42 | import qualified Peano 43 | import qualified Perm 44 | import qualified Poly 45 | import qualified Polydiv 46 | import qualified Prime 47 | import qualified Quotient 48 | import qualified Ranges 49 | import qualified Rat 50 | import qualified Refinement_common 51 | import qualified Rules 52 | import qualified Segment 53 | import qualified Seq 54 | import qualified Specif 55 | import qualified Ssralg 56 | import qualified Ssrbool 57 | import qualified Ssreflect 58 | import qualified Ssrfun 59 | import qualified Ssrint 60 | import qualified Ssrnat 61 | import qualified Ssrnum 62 | import qualified Symbolic 63 | import qualified Symbolic0 64 | import qualified Tuple 65 | import qualified Types 66 | import qualified Vector 67 | import qualified Word 68 | import qualified Zmodp 69 | 70 | import Haskell.Util 71 | import Haskell.ImplicitEffects 72 | import Haskell.Pretty 73 | import Haskell.Inspect 74 | import Haskell.Types 75 | import Haskell.Word 76 | import Haskell.Machine 77 | import Haskell.Assembler hiding 78 | ( nop, const_, mov, binop, load, store, jump, bnz, jal 79 | , jumpEpc, addRule, getTag, putTag, halt ) 80 | import Haskell.OS 81 | 82 | import Control.Applicative 83 | import Control.Monad 84 | import Control.Lens 85 | 86 | listing :: State -> [MWord] -> IO () 87 | listing = (print .) . inspectAddrs 88 | 89 | aroundPC :: State -> Integer -> IO () 90 | aroundPC = (print .) . inspectAroundPC 91 | 92 | regfile :: State -> IO () 93 | regfile = print . inspectRegFile 94 | 95 | summarize :: State -> [MWord] -> Integer -> IO () 96 | summarize s as r = do putStrLn "Instructions:" 97 | aroundPC s r 98 | putStrLn "" 99 | putStrLn "Registers:" 100 | regfile s 101 | unless (null as) $ do 102 | putStrLn "" 103 | putStrLn "Data:" 104 | listing s as 105 | 106 | runState :: SyscallAddresses -> State -> [MWord] -> Integer -> Integer -> IO () 107 | runState addrs s0 as r n = do 108 | let (i,s) = stepMany' addrs n s0 109 | putStrLn $ concat [ "Ran for ", show i, "/", show n 110 | , " step", if i == 1 then "" else "s" ] 111 | putStrLn "" 112 | summarize s as r 113 | 114 | runOS'' :: [MWord] -> Integer -> Integer -> IO () 115 | runOS'' = runState osSyscalls os0 116 | 117 | runOS' :: Integer -> Integer -> IO () 118 | runOS' = runOS'' [osInfo^.osSharedAddress] 119 | 120 | runOS :: Integer -> IO () 121 | runOS = runOS' 3 122 | -------------------------------------------------------------------------------- /cfi/rules.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat. 2 | From CoqUtils Require Import hseq. 3 | 4 | Require Import lib.utils common.types symbolic.symbolic. 5 | Require Import cfi.classes. 6 | 7 | Import Symbolic. 8 | 9 | Set Implicit Arguments. 10 | Unset Strict Implicit. 11 | Unset Printing Implicit Defensive. 12 | 13 | Section uhandler. 14 | 15 | Context {mt : machine_types}. 16 | Context {ops : machine_ops mt}. 17 | 18 | Context {ids : cfi_id mt}. 19 | 20 | Inductive cfi_tag : Type := 21 | | INSTR : option id -> cfi_tag 22 | | DATA : cfi_tag. 23 | 24 | Definition get_id tg := 25 | match tg with 26 | | DATA 27 | | INSTR None => None 28 | | INSTR x => x 29 | end. 30 | 31 | Definition cfi_tag_eq t1 t2 := 32 | match t1, t2 with 33 | | INSTR id1, INSTR id2 => id1 == id2 34 | | DATA, DATA => true 35 | | _, _ => false 36 | end. 37 | 38 | Lemma cfi_tag_eqP : Equality.axiom cfi_tag_eq. 39 | Proof. 40 | by move=> [w1|] [w2|] /=; apply: (iffP idP) => // [/eqP->|[->]]. 41 | Qed. 42 | 43 | Definition cfi_tag_eqMixin := EqMixin cfi_tag_eqP. 44 | Canonical cfi_tag_eqType := Eval hnf in EqType cfi_tag cfi_tag_eqMixin. 45 | 46 | (* XXX: Refine this later to use different types *) 47 | Definition cfi_tags := {| 48 | Symbolic.pc_tag_type := [eqType of cfi_tag]; 49 | Symbolic.reg_tag_type := [eqType of cfi_tag]; 50 | Symbolic.mem_tag_type := [eqType of cfi_tag]; 51 | Symbolic.entry_tag_type := [eqType of cfi_tag] 52 | |}. 53 | 54 | Variable cfg : id -> id -> bool. 55 | 56 | Definition default_rtag (op : opcode) : type_of_result cfi_tags (outputs op) := 57 | match outputs op as o return type_of_result cfi_tags o with 58 | | Some P => DATA 59 | | Some R => DATA 60 | | Some M => DATA 61 | | None => tt 62 | end. 63 | 64 | (* This allows loading of instructions as DATA *) 65 | Definition cfi_handler (ivec : Symbolic.ivec cfi_tags) : option (Symbolic.vovec cfi_tags (Symbolic.op ivec)) := 66 | match ivec return option (Symbolic.vovec cfi_tags (Symbolic.op ivec)) with 67 | | IVec (JUMP as op) (INSTR (Some n)) (INSTR (Some m)) _ 68 | | IVec (JAL as op) (INSTR (Some n)) (INSTR (Some m)) _ => 69 | if cfg n m then Some (@OVec cfi_tags op (INSTR (Some m)) (default_rtag op)) 70 | else None 71 | | IVec (JUMP as op) DATA (INSTR (Some n)) _ 72 | | IVec (JAL as op) DATA (INSTR (Some n)) _ => 73 | Some (@OVec cfi_tags op (INSTR (Some n)) (default_rtag op)) 74 | | IVec JUMP DATA (INSTR None) _ 75 | | IVec JAL DATA (INSTR None) _ => 76 | None 77 | | IVec STORE (INSTR (Some n)) (INSTR (Some m)) [hseq _ ; _ ; DATA] => 78 | if cfg n m then Some (@OVec cfi_tags STORE DATA DATA) else None 79 | | IVec STORE DATA (INSTR _) [hseq _ ; _ ; DATA] => 80 | Some (@OVec cfi_tags STORE DATA DATA) 81 | | IVec STORE _ _ _ => None 82 | | IVec (OP op) (INSTR (Some n)) (INSTR (Some m)) _ => 83 | (* this includes op = SERVICE *) 84 | if cfg n m then Some (@OVec cfi_tags op DATA (default_rtag op)) else None 85 | | IVec (OP op) DATA (INSTR _) _ => 86 | (* this includes op = SERVICE, fall-throughs checked statically *) 87 | Some (@OVec cfi_tags op DATA (default_rtag op)) 88 | | IVec SERVICE (INSTR (Some n)) (INSTR (Some m)) _ => 89 | if cfg n m then Some tt else None 90 | | IVec SERVICE DATA (INSTR _) _ => 91 | Some tt 92 | | IVec _ _ _ _ => None 93 | end. 94 | 95 | Ltac handler_equiv_tac := 96 | match goal with 97 | | [|- match ?Expr with _ => _ end = _] => 98 | destruct Expr 99 | | [|- _ = match ?Expr with _ => _ end] => 100 | destruct Expr 101 | | [|- ?E = ?E] => reflexivity 102 | end. 103 | 104 | End uhandler. 105 | -------------------------------------------------------------------------------- /extraction/postprocess/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, OverloadedStrings #-} 2 | 3 | module Main (printHelp, main) where 4 | 5 | import Data.Monoid 6 | 7 | import qualified Data.Text as T 8 | import qualified Data.Text.IO as T 9 | 10 | import System.Environment 11 | import System.Exit 12 | 13 | import Postprocess.Processor 14 | import Postprocess 15 | 16 | printHelp :: IO () 17 | printHelp = do 18 | name <- T.pack <$> getProgName 19 | T.putStrLn $ "Usage: " <> name 20 | T.putStrLn $ " " <> name <> " EXTRACTION-DIR" 21 | T.putStrLn $ " " <> name <> " EXTRACTION-DIR TARGET-DIR" 22 | T.putStrLn $ " " <> name <> " EXTRACTION-DIR TARGET-DIR EXTRA-DIR" 23 | T.putStrLn $ " " <> name <> " --help" 24 | T.putStrLn $ " " <> name <> " -h" 25 | T.putStrLn "" 26 | T.putStrLn "Cleans up extracted Coq code for use with GHC by:" 27 | T.putStrLn " (1) Removing CPP and Hugs references." 28 | T.putStrLn " (2) Cleaning up pragmas and adding a warning-silencing pragma" 29 | T.putStrLn " (3) Fixing errors (misplaced imports and variables with illegal names)." 30 | T.putStrLn " (4) Inserting all necessary qualified module imports." 31 | T.putStrLn " (5) Optionally, inserting arbitrary extra code." 32 | T.putStrLn " (6) Optionally, inserting extra constraints into type signatures." 33 | T.putStrLn "" 34 | T.putStrLn "Without arguments, fixes Haskell code given on stdin and prints the result to" 35 | T.putStrLn "stdout." 36 | T.putStrLn "" 37 | T.putStrLn "With one non-help argument, fixes every .hs file in the given directory," 38 | T.putStrLn "including uppercasing the first letter of the filename." 39 | T.putStrLn "" 40 | T.putStrLn "With two arguments, removes every `.hs' file in the first directory and creates" 41 | T.putStrLn "an identically-named (modulo case) fixed file in the second directory." 42 | T.putStrLn "" 43 | T.putStrLn "With three arguments, operates as with two arguments, except extra code may be" 44 | T.putStrLn "added to each file by looking in the extra directory for `.hs' files with the" 45 | T.putStrLn "same name as the source." 46 | T.putStrLn "" 47 | T.putStrLn "If this extra code (or the generated code, hypothetically) contains pragmas of" 48 | T.putStrLn "the form `{-# POSTPROCESS CONSTRAINT val :: con1 tv1, con2 tv2, ... #-}', then" 49 | T.putStrLn "these pragmas are removed; instead, the value `val', if defined in the file, has" 50 | T.putStrLn "the various `conN tvN` constraints prepended to its type signature. The `conN'" 51 | T.putStrLn "must be individual Haskell names (probably qualified); the `tvN' must be" 52 | T.putStrLn "unsigned integers that specify the (0-based, left-to-right) index of the type" 53 | T.putStrLn "variable to constrain. Thus, `val :: (a -> b) -> a' with the pragma" 54 | T.putStrLn "`{-# POSTPROCESS CONSTRAINT val :: Eq 0, Ord 1 #-}' will become" 55 | T.putStrLn "`val :: (Eq a, Ord b) => (a -> b) -> a'. Note that type variables referenced on" 56 | T.putStrLn "lines after the `::' will not be found. Malformed pragmas are silently passed" 57 | T.putStrLn "through to the cleaned-up code; invalid type variable indices will cause the" 58 | T.putStrLn "pragma to silently not be applied." 59 | T.putStrLn "" 60 | T.putStrLn "With `--help` or `-h`, or with more than three arguments, prints this help." 61 | 62 | main :: IO () 63 | main = getArgs >>= \case 64 | ["--help"] -> printHelp 65 | ["-h"] -> printHelp 66 | [] -> T.interact . run $ fixExtractedCode Nothing [] 67 | [dir] -> fixExtractedCodeDirectory dir dir Nothing 68 | [from, to] -> fixExtractedCodeDirectory from to Nothing 69 | [from, to, extra] -> fixExtractedCodeDirectory from to (Just extra) 70 | _ -> printHelp >> exitFailure 71 | -------------------------------------------------------------------------------- /os/haskell/Haskell/OS/TH/Accessors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, TemplateHaskell #-} 2 | module Haskell.OS.TH.Accessors where 3 | 4 | import Control.Applicative 5 | import Control.Monad 6 | import Control.Monad.Reader (MonadReader()) 7 | import Control.Lens 8 | import Data.Char 9 | import Data.List.Lens 10 | import Language.Haskell.TH 11 | 12 | -- |@recordFields \'\'Foo@ with the data declaration 13 | -- @data Foo = Bar { baz :: Baz, quux :: Quux }@ evaluates to 14 | -- @[("baz",[t|Baz|]), ("quux", [t|Quux|])]@. @recordFields@ ignores strictness 15 | -- and is careless about type variables. 16 | recordFields :: Name -> Q [(String,Type)] 17 | recordFields = reify >=> \case 18 | TyConI dec -> pure $ recordFieldsDec dec 19 | _ -> fail "recordFields: Expected type constructor name" 20 | 21 | -- "Borrowed" from Control.Lens.Internal.FieldTH.makeFieldOpticsForDec 22 | recordFieldsDec :: Dec -> [(String,Type)] 23 | recordFieldsDec dec = case dec of 24 | DataD _cxt _ty _tvs cons _deriving -> 25 | extractFields cons 26 | NewtypeD _cxt _ty _tvs con _deriving -> 27 | extractFields [con] 28 | DataInstD _cxt _ty _targs cons _deriving -> 29 | extractFields cons 30 | NewtypeInstD _cxt _ty _targs con _deriving -> 31 | extractFields [con] 32 | _ -> fail "recordFieldsDec: Expected data or newtype type-constructor" 33 | where 34 | extractFields [RecC _name fields] = 35 | [(nameBase field, ty) | (field,_,ty) <- fields] 36 | extractFields [_] = 37 | fail "recordFieldsDec: Expected a (non-quantified) record constructor" 38 | extractFields [] = 39 | fail "recordFieldsDec: No constructors in type declaration" 40 | extractFields _ = 41 | fail "recordFieldsDec: Too many constructors in type declaration" 42 | 43 | -- |@makeMonadicAccessors ''Foo@ with the data declaration 44 | -- @data Foo = Bar { _bazVal :: Baz, _quuxVal :: Quux }@ in scope produces the 45 | -- declarations 46 | -- 47 | -- @ 48 | -- baz :: (HasBar p, MonadReader p m) => m Baz 49 | -- baz = view bazVal 50 | -- 51 | -- quux :: (HasBar p, MonadReader p m) => m Quux 52 | -- quux = view quuxVal 53 | -- @ 54 | -- 55 | -- Note the requirement for the @_fieldVal@ syntax -- the @_@ is optional, but 56 | -- the @Val@ is mandatory. 57 | makeMonadicAccessors :: Name -> DecsQ 58 | makeMonadicAccessors tyName = do 59 | let assertName lookupName nameStr = 60 | maybe (fail $ "makeMonadicAccessors: Could not find `" 61 | ++ nameStr ++ "'") 62 | pure 63 | =<< lookupName nameStr 64 | 65 | hasClass <- assertName lookupTypeName$ "Has" ++ nameBase tyName 66 | fields <- recordFields tyName 67 | 68 | let makeMonadicAccessor (fieldName, fieldTy) = do 69 | let lensName = dropWhile (== '_') fieldName & _head %~ toLower 70 | lens <- assertName lookupValueName lensName 71 | accessor <- case stripSuffix "Val" lensName of 72 | Just accessorName -> 73 | pure $ mkName accessorName 74 | Nothing -> 75 | fail $ "makeMonadicAccessors: " 76 | ++ "Could not make accessor name for `" 77 | ++ fieldName ++ "'" 78 | 79 | let accessorType = 80 | let pName = mkName "p" 81 | p = VarT pName 82 | mName = mkName "m" 83 | m = VarT mName 84 | in ForallT [PlainTV pName, PlainTV mName] 85 | [ ClassP hasClass [p] 86 | , ClassP ''MonadReader [p,m] ] 87 | (m `AppT` fieldTy) 88 | pure [ SigD accessor accessorType 89 | , ValD (VarP accessor) (NormalB $ VarE 'view `AppE` VarE lens) [] ] 90 | concat <$> mapM makeMonadicAccessor fields 91 | -------------------------------------------------------------------------------- /testing/Generation.v: -------------------------------------------------------------------------------- 1 | Require Import QuickChick. 2 | 3 | Require Import common. 4 | Require Import concrete. 5 | Require Import concrete_exec. 6 | Require Import concrete_int_32. 7 | Require Import concrete_monitor. 8 | Require Import fault_handler. 9 | Require Import testing. 10 | 11 | Require Import ZArith. 12 | Require Import Integers. 13 | Require Import List. 14 | Require Import Coq.Strings.String. 15 | Import ListNotations. 16 | 17 | Import Concrete. 18 | 19 | Definition state := state concrete_int_32_t. 20 | Definition word := word concrete_int_32_t. 21 | Definition monitor_regs := monitor_regs concrete_int_32_t concrete_int_32_fh. 22 | Definition reg := reg concrete_int_32_t. 23 | Definition atom := atom concrete_int_32_t. 24 | Definition mkatom := mkatom concrete_int_32_t. 25 | Definition registers := registers concrete_int_32_t. 26 | Definition memory := memory concrete_int_32_t. 27 | 28 | Definition word_eq_dec : forall (x y : word), {x = y} + {~ (x = y)} := 29 | word_mt_eq_dec reflect_eq_word. 30 | 31 | Definition gen_word : Gen word := liftGen Z_to_word arbitrary. 32 | 33 | (* Generates a valid register : 34 | - The value of the register is an arbitrary integer (TODO: Fix? Does it matter?) 35 | - The tag of the register depends on the register ID (monitor/non-monitor) *) 36 | Definition gen_register (r : reg) : Gen atom := 37 | liftGen2 mkatom gen_word 38 | (if in_dec word_eq_dec r monitor_regs then 39 | returnGen TMonitor 40 | else returnGen TNone). 41 | 42 | Definition nat_to_reg (n : nat) : reg := 43 | Z_to_word (Z_of_nat n). 44 | 45 | Definition gen_register_nat (n : nat) : Gen atom := 46 | gen_register (nat_to_reg n). 47 | 48 | (* TODO: How many should I generate??? *) 49 | Definition gen_registers (n : nat) : Gen registers := 50 | foldGen (fun a b => liftGen (upd_reg a (nat_to_reg b)) (gen_register_nat b)) 51 | (seq 0 n) initial_regs. 52 | 53 | (* TODO: Maybe we want to generate random cache configurations? *) 54 | Definition gen_cache : Gen (rules word) := returnGen concrete_ground_rules. 55 | 56 | (* First thousand -> Monitor constants 57 | Second thousand -> User Program 58 | Third thousand -> Faulthandler *) 59 | Definition gen_memory : Gen memory := returnGen initial_memory. 60 | 61 | (* 62 | Fixpoint constants_from {A : Type} (i : int) (n : nat) (x : A) 63 | (mem : Int32PMap.t A) : Int32PMap.t A := 64 | match n with 65 | | O => mem 66 | | S n' => constants_from (add i one) n' x (Int32PMap.set i x mem) 67 | end. 68 | 69 | 70 | Definition initial_memory : Concrete.memory concrete_int_32_t := 71 | let monitorZero := Concrete.mkatom concrete_int_32_t zero Concrete.TMonitor in 72 | let withNone w := w @ Concrete.TNone 73 | in ( constants_from zero 1000 monitorZero 74 | ∘ insert_from_as (repr 1000) hello_world withNone 75 | ∘ insert_from_as (repr 2000) faulthandler_bin withNone ) 76 | (Int32PMap.empty _). 77 | *) 78 | 79 | Definition gen_pc : Gen atom := returnGen (pc initial_state). 80 | 81 | Definition gen_state : Gen state := 82 | bindGen gen_memory (fun m => 83 | bindGen (gen_registers 42) (fun r => 84 | bindGen gen_cache (fun c => 85 | bindGen gen_pc (fun pc => 86 | returnGen {| 87 | mem := m; 88 | regs := r; 89 | cache := c; 90 | pc := pc; 91 | epc := epc (initial_state) 92 | |})))). 93 | 94 | Require Import Integers. 95 | 96 | Definition prop_mi := 97 | forAllShrink (fun _ => "Foo"%string) (returnGen initial_state) (fun _ => []) 98 | (fun s => 99 | invariant_exec concrete_int_32_fh reflect_eq_word (Z_to_word 2000) 100 | (mem s) (regs s) (cache s)). 101 | 102 | Definition toTest := quickCheck prop_mi. 103 | 104 | QuickCheck toTest. 105 | -------------------------------------------------------------------------------- /concrete/int_32.v: -------------------------------------------------------------------------------- 1 | (* Instantiate the concrete machine with 32-bit integers *) 2 | 3 | From mathcomp Require Import 4 | ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype ssrint tuple. 5 | From extructures Require Import ord fmap. 6 | From CoqUtils Require Import hseq word. 7 | 8 | Require Import lib.utils. 9 | Require Import common.types common.printing. 10 | Require Import concrete.concrete. 11 | 12 | Set Implicit Arguments. 13 | Unset Strict Implicit. 14 | Unset Printing Implicit Defensive. 15 | 16 | Import DoNotation. 17 | 18 | Program Definition concrete_int_32_mt : machine_types := {| 19 | word_size := 32; 20 | reg_field_size := 5; 21 | imm_size := 15 22 | |}. 23 | 24 | Local Notation mt := concrete_int_32_mt. 25 | 26 | Definition fields_of_op op : seq nat := 27 | match op with 28 | | NOP => [:: 27] 29 | | CONST => [:: 15; 5; 7] 30 | | MOV => [:: 5; 5; 17] 31 | | BINOP _ => [:: 5; 5; 5; 12] 32 | | LOAD => [:: 5; 5; 17] 33 | | STORE => [:: 5; 5; 17] 34 | | JUMP => [:: 5; 22] 35 | | BNZ => [:: 5; 15; 7] 36 | | JAL => [:: 5; 22] 37 | | JUMPEPC => [:: 27] 38 | | ADDRULE => [:: 27] 39 | | GETTAG => [:: 5; 5; 17] 40 | | PUTTAG => [:: 5; 5; 5; 12] 41 | | HALT => [:: 27] 42 | end. 43 | 44 | Lemma fields_of_opP op : sumn (fields_of_op op) = 27. 45 | Proof. by case: op. Qed. 46 | 47 | Definition args_of_instr (i : instr mt) : hseq word (fields_of_op (opcode_of i)) := 48 | match i with 49 | | Nop => [hseq 0%w] 50 | | Const i r => [hseq i : word _; r : word _; 0%w] 51 | | Mov r1 r2 => [hseq r1 : word _; r2 : word _; 0%w] 52 | | Binop _ r1 r2 r3 => [hseq r1 : word _; r2 : word _; r3 : word _; zerow] 53 | | Load r1 r2 => [hseq r1 : word _; r2 : word _; 0%w] 54 | | Store r1 r2 => [hseq r1 : word _; r2 : word _; 0%w] 55 | | Jump r => [hseq r : word _; 0%w] 56 | | Bnz r i => [hseq r : word _; i : word _; 0%w] 57 | | Jal r => [hseq r : word _; 0%w] 58 | | JumpEpc => [hseq 0%w] 59 | | AddRule => [hseq 0%w] 60 | | GetTag r1 r2 => [hseq r1 : word _; r2 : word _; 0%w] 61 | | PutTag r1 r2 r3 => [hseq r1 : word _; r2 : word _; r3 : word _; 0%w] 62 | | Halt => [hseq 0%w] 63 | end. 64 | 65 | Definition instr_of_args op : hseq word (fields_of_op op) -> instr mt := 66 | match op with 67 | | NOP => fun args => Nop mt 68 | | CONST => fun args => @Const mt [hnth args 0] [hnth args 1] 69 | | MOV => fun args => @Mov mt [hnth args 0] [hnth args 1] 70 | | BINOP b => fun args => @Binop mt b [hnth args 0] [hnth args 1] [hnth args 2] 71 | | LOAD => fun args => @Load mt [hnth args 0] [hnth args 1] 72 | | STORE => fun args => @Store mt [hnth args 0] [hnth args 1] 73 | | JUMP => fun args => @Jump mt [hnth args 0] 74 | | BNZ => fun args => @Bnz mt [hnth args 0] [hnth args 1] 75 | | JAL => fun args => @Jal mt [hnth args 0] 76 | | JUMPEPC => fun args => JumpEpc mt 77 | | ADDRULE => fun args => AddRule mt 78 | | GETTAG => fun args => @GetTag mt [hnth args 0] [hnth args 1] 79 | | PUTTAG => fun args => @PutTag mt [hnth args 0] [hnth args 1] [hnth args 2] 80 | | HALT => fun args => Halt mt 81 | end. 82 | 83 | Lemma args_of_instrK i : instr_of_args (args_of_instr i) = i. 84 | Proof. 85 | by case: i => * //=; rewrite /hnth /tnth /=; 86 | do !rewrite ![in X in eq_rect _ _ _ _ X]eq_axiomK /=. 87 | Qed. 88 | 89 | Instance concrete_int_32_ops : machine_ops mt := {| 90 | encode_instr i := 91 | let op := word_of_op (opcode_of i) in 92 | let args : word 27 := wcast (fields_of_opP _) (wpack (args_of_instr i)) in 93 | @wpack [:: 5; 27] [hseq op; args]; 94 | 95 | decode_instr i := 96 | let i' := @wunpack [:: 5; 27] i in 97 | let op := [hnth i' 0] in 98 | do! op <- op_of_word op; 99 | let args := wcast (esym (fields_of_opP op)) [hnth i' 1] in 100 | Some (instr_of_args (wunpack args)); 101 | 102 | ra := zerow 103 | 104 | |}. 105 | 106 | Instance concrete_int_32_ops_spec : machine_ops_spec concrete_int_32_ops. 107 | Proof. 108 | constructor=> i. 109 | rewrite /decode_instr /encode_instr /= wpackK /hnth /=. 110 | by rewrite word_of_opK //= wcastK wpackK args_of_instrK. 111 | Qed. 112 | -------------------------------------------------------------------------------- /ifc/common.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq. 2 | From extructures Require Import ord fmap. 3 | From CoqUtils Require Import hseq word. 4 | From MicroPolicies Require Import lib.utils common.types ifc.labels. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | 10 | Class ifc_addrs mt := IFCAddrs { 11 | output_addr : mword mt; 12 | call_addr : mword mt; 13 | return_addr : mword mt 14 | }. 15 | 16 | Section CallFrame. 17 | 18 | Variable mt : machine_types. 19 | Variable L : labType. 20 | 21 | Record call_frame := CallFrame { 22 | cf_pc : atom (mword mt) L; 23 | cf_regs : {fmap reg mt -> atom (mword mt) L} 24 | }. 25 | 26 | Definition tuple_of_call_frame cf := 27 | (cf_pc cf, cf_regs cf). 28 | 29 | Definition call_frame_of_tuple cf := 30 | let: (pc, regs) := cf in 31 | CallFrame pc regs. 32 | 33 | Lemma tuple_of_call_frameK : cancel tuple_of_call_frame call_frame_of_tuple. 34 | Proof. by case. Qed. 35 | 36 | Definition call_frame_eqMixin := CanEqMixin tuple_of_call_frameK. 37 | Canonical call_frame_eqType := 38 | Eval hnf in EqType call_frame call_frame_eqMixin. 39 | 40 | End CallFrame. 41 | 42 | Fixpoint reap T p (s : seq T) : seq T := 43 | if s is x :: s' then 44 | if p x then reap p s' else s 45 | else [::]. 46 | 47 | Section Indist. 48 | 49 | Context {T : eqType} {L : labType}. 50 | Variable t : T -> L. 51 | 52 | Local Open Scope label_scope. 53 | 54 | Definition indist rs (ra1 ra2 : T) := 55 | (t ra1 ⊑ rs) || (t ra2 ⊑ rs) ==> (ra1 == ra2). 56 | 57 | CoInductive indist_spec rs ra1 ra2 : Prop := 58 | | IndistLow of t ra1 ⊑ rs & t ra2 ⊑ rs & ra1 = ra2 59 | | IndistHigh of ~~ (t ra1 ⊑ rs) & ~~ (t ra2 ⊑ rs). 60 | 61 | Lemma indistP rs ra1 ra2 : 62 | reflect (indist_spec rs ra1 ra2) (indist rs ra1 ra2). 63 | Proof. 64 | rewrite /indist; apply/(iffP idP). 65 | have [hi /eqP <-|lo1] /= := boolP (t ra1 ⊑ rs); first by constructor. 66 | have [hi /eqP e|lo2 _] /= := boolP (t ra2 ⊑ rs). 67 | by rewrite e hi in lo1. 68 | by apply: IndistHigh. 69 | case=> [-> -> -> //=|hi1 hi2]. 70 | by rewrite -[X in X ==> _]negbK negb_or hi1 hi2. 71 | Qed. 72 | 73 | Lemma indist_refl rl : reflexive (indist rl). 74 | Proof. by move=> ra; rewrite /indist eqxx implybT. Qed. 75 | 76 | Lemma indist_sym rl : symmetric (indist rl). 77 | Proof. by move=> ra1 ra2; rewrite /indist orbC eq_sym. Qed. 78 | 79 | Lemma indist_trans rl : transitive (indist rl). 80 | Proof. 81 | move=> ra2 ra1 ra3; rewrite /indist => e1 e2. 82 | apply/implyP=> /orP [e|e]. 83 | by move: e1 e2; rewrite e /= => /eqP <-; rewrite e => /eqP ->. 84 | by move: e2 e1; rewrite e orbT /= => /eqP ->; rewrite e orbT /= => /eqP ->. 85 | Qed. 86 | 87 | End Indist. 88 | 89 | Section IndistSeq. 90 | 91 | Variables (T : Type) (R : T -> T -> Prop). 92 | 93 | Fixpoint indist_seq (s1 s2 : seq T) := 94 | match s1, s2 with 95 | | x1 :: s1', x2 :: s2' => R x1 x2 /\ indist_seq s1' s2' 96 | | [::], [::] => True 97 | | _, _ => False 98 | end. 99 | 100 | Lemma indist_seq_sym : 101 | (forall x y, R x y -> R y x) -> 102 | (forall s1 s2, indist_seq s1 s2 -> indist_seq s2 s1). 103 | Proof. 104 | move=> sym. 105 | elim=> [|x1 s1 IH] [|x2 s2] //= [/sym ??]. 106 | split=> //; exact: IH. 107 | Qed. 108 | 109 | Fixpoint indist_seq_prefix (s1 s2 : seq T) := 110 | match s1, s2 with 111 | | x1 :: s1', x2 :: s2' => R x1 x2 /\ indist_seq_prefix s1' s2' 112 | | _, _ => True 113 | end. 114 | 115 | Lemma indist_seq_prefix_sym : 116 | (forall x y, R x y -> R y x) -> 117 | (forall s1 s2, indist_seq_prefix s1 s2 -> indist_seq_prefix s2 s1). 118 | Proof. 119 | move=> sym. 120 | elim=> [|x1 s1 IH] [|x2 s2] //= [/sym ??]. 121 | split=> //; exact: IH. 122 | Qed. 123 | 124 | Lemma indist_seq_cat s1 s1' s2 s2' : 125 | indist_seq s1 s2 -> 126 | indist_seq s1' s2' -> 127 | indist_seq (s1 ++ s1') (s2 ++ s2'). 128 | Proof. 129 | elim: s1 s2 => [|x1 s1 IH] [|x2 s2] //= [hx hs hs']. 130 | by split; eauto. 131 | Qed. 132 | 133 | Lemma indist_seq_cat_prefix s1 s1' s2 s2' : 134 | indist_seq s1 s2 -> 135 | indist_seq_prefix s1' s2' -> 136 | indist_seq_prefix (s1 ++ s1') (s2 ++ s2'). 137 | Proof. 138 | elim: s1 s2 => [|x1 s1 IH] [|x2 s2] //= [hx hs hs']. 139 | by split; eauto. 140 | Qed. 141 | 142 | Lemma indist_seq_prefix_sub s1 s1' s2 s2' : 143 | indist_seq_prefix (s1 ++ s1') (s2 ++ s2') -> 144 | indist_seq_prefix s1 s2. 145 | Proof. 146 | elim: s1 s2 => [|x1 s1 IH] [|x2 s2] //= [hx hs]. 147 | by eauto. 148 | Qed. 149 | 150 | End IndistSeq. 151 | -------------------------------------------------------------------------------- /ifc/abstract.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import 2 | ssreflect ssrfun ssrbool ssrnat eqtype seq choice fintype finfun. 3 | From extructures Require Import ord fmap. 4 | From CoqUtils Require Import hseq word. 5 | From MicroPolicies Require Import lib.utils common.types ifc.labels ifc.common. 6 | 7 | Set Implicit Arguments. 8 | Unset Strict Implicit. 9 | Unset Printing Implicit Defensive. 10 | 11 | Section Abstract. 12 | 13 | Import DoNotation. 14 | 15 | Variable L : labType. 16 | Variable mt : machine_types. 17 | Variable mops : machine_ops mt. 18 | Context {sregs : syscall_regs mt}. 19 | Context {addrs : ifc_addrs mt}. 20 | 21 | Local Notation word := (mword mt). 22 | Local Notation atom := (atom word L). 23 | 24 | Record state := State { 25 | mem : {fmap mword mt -> instr mt + atom}; 26 | regs : {fmap reg mt -> atom}; 27 | pc : atom; 28 | call_stack : seq (call_frame mt L) 29 | }. 30 | 31 | Local Open Scope word_scope. 32 | Local Open Scope label_scope. 33 | 34 | Implicit Type s : state. 35 | 36 | Definition step s : option (state * option atom):= 37 | let: State mem regs pc@lpc stk := s in 38 | if mem pc is Some i then 39 | if i is inl i then 40 | match i with 41 | | Nop => Some (State mem regs (pc + 1)@lpc stk, None) 42 | | Const k r => 43 | do! regs <- updm regs r (swcast k)@⊥; 44 | Some (State mem regs (pc + 1)@lpc stk, None) 45 | | Mov r1 r2 => 46 | do! v <- regs r1; 47 | do! regs <- updm regs r2 v; 48 | Some (State mem regs (pc + 1)@lpc stk, None) 49 | | Binop o r1 r2 r3 => 50 | do! v1 <- regs r1; 51 | do! v2 <- regs r2; 52 | do! regs <- updm regs r3 (binop_denote o (vala v1) (vala v2))@(taga v1 ⊔ taga v2); 53 | Some (State mem regs (pc + 1)@lpc stk, None) 54 | | Load r1 r2 => 55 | do! v1 <- regs r1; 56 | do! v2 <- mem (vala v1); 57 | if v2 is inr v2 then 58 | do! regs <- updm regs r2 (vala v2)@(taga v1 ⊔ taga v2); 59 | Some (State mem regs (pc + 1)@lpc stk, None) 60 | else None 61 | | Store r1 r2 => 62 | do! v1 <- regs r1; 63 | do! v2 <- regs r2; 64 | do! vold <- mem (vala v1); 65 | if vold is inr vold then 66 | if taga v1 ⊔ lpc ⊑ taga vold then 67 | do! mem <- updm mem (vala v1) 68 | (inr (vala v2)@(taga v1 ⊔ taga v2 ⊔ lpc)); 69 | Some (State mem regs (pc + 1)@lpc stk, None) 70 | else None 71 | else None 72 | | Jump r => 73 | do! v <- regs r; 74 | Some (State mem regs (vala v)@(taga v ⊔ lpc) stk, None) 75 | | Bnz r x => 76 | do! v <- regs r; 77 | let pc' := pc + if vala v == 0 then 1 78 | else swcast x in 79 | Some (State mem regs pc'@(taga v ⊔ lpc) stk, None) 80 | | Jal r => 81 | do! v <- regs r; 82 | do! regs <- updm regs ra (pc + 1)@⊥; 83 | Some (State mem regs (vala v)@(taga v ⊔ lpc) stk, None) 84 | | JumpEpc => None 85 | | AddRule => None 86 | | GetTag _ _ => None 87 | | PutTag _ _ _ => None 88 | | Halt => None 89 | end 90 | else None 91 | 92 | (* Note that we often need to adjust the tag on the caller pc because it may be 93 | lower than the one on the current pc; for example, if we jump to the service 94 | via BNZ instead of JAL. *) 95 | else if pc == return_addr then 96 | if stk is cf :: stk' then 97 | do! retv <- regs syscall_ret; 98 | do! rs' <- updm (cf_regs cf) syscall_ret (vala retv)@(lpc ⊔ taga retv); 99 | Some (State mem rs' (cf_pc cf) stk', None) 100 | else None 101 | else if pc == call_addr then 102 | do! caller_pc <- regs ra; 103 | let caller_pc := (vala caller_pc)@(taga caller_pc ⊔ lpc) in 104 | do! called_pc <- regs syscall_arg1; 105 | Some (State mem regs 106 | (vala called_pc)@(taga called_pc ⊔ taga caller_pc) 107 | (CallFrame caller_pc regs :: stk), None) 108 | else if pc == output_addr then 109 | do! raddr <- regs ra; 110 | let r_pc := taga raddr ⊔ lpc in 111 | let raddr := (vala raddr)@r_pc in 112 | do! out <- regs syscall_arg1; 113 | let r_out := taga out in 114 | Some (State mem regs raddr stk, 115 | Some (vala out)@(lpc ⊔ r_out)) 116 | else None. 117 | 118 | Fixpoint trace n s := 119 | if n is S n' then 120 | if step s is Some (s', oe) then 121 | seq_of_opt oe ++ trace n' s' 122 | else [::] 123 | else [::]. 124 | 125 | End Abstract. 126 | -------------------------------------------------------------------------------- /ifc/labels.v: -------------------------------------------------------------------------------- 1 | From mathcomp 2 | Require Import ssreflect ssrfun ssrbool ssrnat eqtype choice. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | Delimit Scope label_scope with lab. 9 | 10 | Module Label. 11 | 12 | Section ClassDef. 13 | 14 | Record mixin_of T := Mixin { 15 | join : T -> T -> T; 16 | top : T; 17 | bot : T; 18 | _ : commutative join; 19 | _ : associative join; 20 | _ : idempotent join; 21 | _ : left_id bot join; 22 | _ : left_zero top join 23 | }. 24 | 25 | Record class_of T := Class {base : Choice.class_of T; mixin : mixin_of T}. 26 | Local Coercion base : class_of >-> Choice.class_of. 27 | 28 | Structure type := Pack {sort; _ : class_of sort}. 29 | Local Coercion sort : type >-> Sortclass. 30 | Variables (T : Type) (cT : type). 31 | Definition class := let: Pack _ c as cT' := cT return class_of cT' in c. 32 | Definition clone c of phant_id class c := @Pack T c. 33 | Let xT := let: Pack T _ := cT in T. 34 | Notation xclass := (class : class_of xT). 35 | 36 | Definition pack m := 37 | fun b bT & phant_id (Choice.class bT) b => Pack (@Class T b m). 38 | 39 | (* Inheritance *) 40 | Definition eqType := @Equality.Pack cT xclass. 41 | 42 | Definition choiceType := @Choice.Pack cT xclass. 43 | 44 | End ClassDef. 45 | 46 | Module Import Exports. 47 | Coercion base : class_of >-> Choice.class_of. 48 | Coercion mixin : class_of >-> mixin_of. 49 | Coercion sort : type >-> Sortclass. 50 | Coercion eqType : type >-> Equality.type. 51 | Canonical eqType. 52 | Coercion choiceType : type >-> Choice.type. 53 | Canonical choiceType. 54 | Notation labType := type. 55 | Notation labMixin := mixin_of. 56 | Notation LabMixin := Mixin. 57 | Notation LabType T m := (@pack T m _ _ id). 58 | Notation "[ 'labType' 'of' T 'for' cT ]" := (@clone T cT _ idfun) 59 | (at level 0, format "[ 'labType' 'of' T 'for' cT ]") : form_scope. 60 | Notation "[ 'labType' 'of' T ]" := (@clone T _ _ id) 61 | (at level 0, format "[ 'labType' 'of' T ]") : form_scope. 62 | End Exports. 63 | 64 | End Label. 65 | 66 | Export Label.Exports. 67 | 68 | Section Theory. 69 | 70 | Local Open Scope label_scope. 71 | 72 | Variable L : labType. 73 | 74 | Implicit Types (l : L). 75 | 76 | Definition join := Label.join (Label.class L). 77 | Definition top := Label.top (Label.class L). 78 | Definition bot := Label.bot (Label.class L). 79 | 80 | Local Notation "l1 ⊔ l2" := 81 | (join l1 l2) (at level 40, left associativity) : label_scope. 82 | Local Notation "⊤" := top : label_scope. 83 | Local Notation "⊥" := bot : label_scope. 84 | 85 | Lemma joinC : commutative join. 86 | Proof. by rewrite /join; case: (L)=> [? [? []]]. Qed. 87 | 88 | Lemma joinA : associative join. 89 | Proof. by rewrite /join; case: (L)=> [? [? []]]. Qed. 90 | 91 | Lemma joinll : idempotent join. 92 | Proof. by rewrite /join; case: (L)=> [? [? []]]. Qed. 93 | 94 | Lemma joinBl : left_id ⊥ join. 95 | Proof. by rewrite /bot /join; case: (L)=> [? [? []]]. Qed. 96 | 97 | Lemma joinTl : left_zero ⊤ join. 98 | Proof. by rewrite /top /join; case: (L)=> [? [? []]]. Qed. 99 | 100 | Lemma joinlB : right_id ⊥ join. 101 | Proof. by move=> l; rewrite joinC joinBl. Qed. 102 | 103 | Lemma joinlT : right_zero ⊤ join. 104 | Proof. by move=> l; rewrite joinC joinTl. Qed. 105 | 106 | (* XXX: Should this be a notation? *) 107 | Definition flows l1 l2 := l1 ⊔ l2 == l2. 108 | 109 | Local Notation "l1 ⊑ l2" := 110 | (flows l1 l2) (at level 50, no associativity) : label_scope. 111 | 112 | Lemma flowsll : reflexive flows. 113 | Proof. by move=> l; rewrite /flows joinll eqxx. Qed. 114 | 115 | Lemma flows_trans : transitive flows. 116 | Proof. 117 | by move=> ???; rewrite /flows => /eqP e /eqP <-; rewrite joinA e. 118 | Qed. 119 | 120 | Lemma flows_antisym : antisymmetric flows. 121 | Proof. 122 | move=> l l'; rewrite /flows => /andP [/eqP e1 /eqP e2]. 123 | by rewrite -e2 joinC. 124 | Qed. 125 | 126 | Lemma flows_join l l1 l2 : (l1 ⊔ l2 ⊑ l) = (l1 ⊑ l) && (l2 ⊑ l). 127 | Proof. 128 | rewrite /flows; apply/(sameP idP)/(iffP andP). 129 | by case=> [e1 /eqP e2]; rewrite -joinA e2. 130 | move=> /eqP e; rewrite -{}e 2!joinA joinll; split=> //. 131 | by rewrite 2!joinA [l2 ⊔ _]joinC -3!joinA [l2 ⊔ _]joinA joinll. 132 | Qed. 133 | 134 | Lemma botP l : ⊥ ⊑ l. 135 | Proof. by rewrite /flows joinBl. Qed. 136 | 137 | Lemma topP l : l ⊑ ⊤. 138 | Proof. by rewrite /flows joinlT. Qed. 139 | 140 | End Theory. 141 | 142 | Notation "l1 ⊔ l2" := 143 | (join l1 l2) (at level 40, left associativity) : label_scope. 144 | Notation "⊤" := (top _) : label_scope. 145 | Notation "⊥" := (bot _) : label_scope. 146 | Notation "l1 ⊑ l2" := 147 | (flows l1 l2) (at level 50, no associativity) : label_scope. 148 | -------------------------------------------------------------------------------- /os/haskell/Haskell/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, OverloadedStrings #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module Haskell.Pretty (module Haskell.Pretty, module PrettyExports) where 4 | 5 | import Haskell.Types 6 | import Haskell.Word 7 | import Haskell.Machine 8 | 9 | import Data.Monoid 10 | import Text.PrettyPrint.HughesPJClass hiding ((<>)) 11 | import Data.Set (Set) 12 | import qualified Data.Set as S 13 | 14 | import Prelude hiding (EQ) 15 | 16 | import qualified Text.PrettyPrint.HughesPJClass as PrettyExports hiding ((<>)) 17 | import qualified Data.Monoid as PrettyExports ((<>)) 18 | 19 | -- Should be exported from Text.PrettyPrint.* :-/ 20 | appPrec :: Rational 21 | appPrec = 10 22 | 23 | () :: (Pretty a, Pretty b) => a -> b -> Doc 24 | a b = pPrint a <> pPrint b 25 | 26 | (<&>) :: (Pretty a, Pretty b) => a -> b -> Doc 27 | a <&> b = pPrint a <+> pPrint b 28 | 29 | (<.!>) :: Pretty a => Doc -> a -> Doc 30 | (<.!>) = () 31 | 32 | () :: Pretty a => a -> Doc -> Doc 33 | () = () 34 | 35 | (<.&>) :: Pretty a => Doc -> a -> Doc 36 | (<.&>) = (<&>) 37 | 38 | (<&.>) :: Pretty a => a -> Doc -> Doc 39 | (<&.>) = (<&>) 40 | 41 | infixl 6 , <.!>, , <&>, <.&>, <&.> 42 | 43 | plain :: Show a => a -> Doc 44 | plain = text . show 45 | 46 | -- There are a lot of orphan instances in this file; basically, imagine that 47 | -- this is where 'Pretty' is defined! 48 | 49 | instance Pretty Doc where pPrint = id -- Orphan, I know, but obviously missing! 50 | 51 | instance Pretty a => Pretty (Set a) where 52 | pPrintPrec l _ = 53 | braces . fsep . punctuate comma . map (pPrintPrec l 0) . S.toList 54 | 55 | instance (Pretty v, Pretty t) => Pretty (Atom v t) where 56 | pPrintPrec l p (v :@ t) = 57 | let ppp :: Pretty a => a -> Doc 58 | ppp = pPrintPrec l $ appPrec + 2 59 | in maybeParens (p > appPrec + 1) $ ppp v <> taggedOp <> ppp t 60 | 61 | instance Pretty (Word n) where pPrint = plain 62 | instance KnownNat n => Pretty (Signed n) where pPrint = plain 63 | 64 | instance Pretty Binop where 65 | pPrint ADD = "+" 66 | pPrint SUB = "-" 67 | pPrint MUL = "*" 68 | pPrint EQ = "=" 69 | pPrint LEQ = "<=?" 70 | pPrint LEQU = "<=!" 71 | pPrint AND = "&" 72 | pPrint OR = "|" 73 | pPrint XOR = "^" 74 | pPrint SHRU = ">>" 75 | pPrint SHL = "<<" 76 | 77 | instance Pretty Reg where pPrint = plain 78 | instance Pretty Imm where pPrint = plain 79 | instance Pretty MWord where pPrint = plain 80 | 81 | instance Pretty WhereFrom where 82 | pPrint = plain 83 | 84 | instance Pretty PCTag where 85 | pPrintPrec l p (PC wf cid) = 86 | let ppp :: Pretty a => a -> Doc 87 | ppp = pPrintPrec l $ appPrec + 1 88 | in maybeParens (p > appPrec) $ "PC" <+> ppp wf <+> ppp cid 89 | 90 | instance Pretty RegTag where 91 | pPrint = plain 92 | 93 | instance Pretty DataTag where 94 | pPrintPrec l p (DATA cid ws is) = 95 | let ppp :: Pretty a => a -> Doc 96 | ppp = pPrintPrec l $ appPrec + 1 97 | in maybeParens (p > appPrec) $ "DATA" <+> ppp cid <+> ppp ws <+> ppp is 98 | 99 | storesOp :: Doc 100 | storesOp = "->" 101 | 102 | getsOp :: Doc 103 | getsOp = "<-" 104 | 105 | taggedOp :: Doc 106 | taggedOp = "@" 107 | 108 | ptrReg :: Reg -> Doc 109 | ptrReg = (char '*' ) 110 | 111 | instance Pretty Instr where 112 | pPrintPrec _ p instr = maybeParens (p > appPrec) $ case instr of 113 | Nop -> nullary "Nop" 114 | Const imm dest -> binary "Const" imm dest 115 | Mov src dest -> binary "Mov" src dest 116 | Binop op src1 src2 dest -> ternary (binopFor op) src1 op src2 dest 117 | Load srcA dest -> binary "Load" (ptrReg srcA) dest 118 | Store destA src -> binary' "Store" (ptrReg destA) getsOp src 119 | Jump pc' -> unary "Jump" pc' 120 | Bnz test delta -> binary' "Bnz" test jumpsOp (withSign delta) 121 | Jal pc' -> unary "Jal" pc' 122 | JumpEpc -> nullary "JumpEpc" 123 | AddRule -> nullary "AddRule" 124 | GetTag src dest -> binary "GetTag" src dest 125 | PutTag srcV srcT dest -> ternary "PutTag" srcV taggedOp srcT dest 126 | Halt -> nullary "Halt" 127 | where 128 | binopFor op = "Binop[" <.!> plain op "]" 129 | 130 | jumpsOp = "=>" :: Doc 131 | withSign = ("+" <>) . pPrint . immWord 132 | -- text . showSigned . Signed . immWord 133 | -- Oops, 'Bnz' can apparently only jump forward 134 | 135 | nullary name = name 136 | unary name r = name <.&> r 137 | binary' name src op dest = name <.&> src <&> op <&> dest 138 | binary name src dest = binary' name src storesOp dest 139 | ternary name src1 op src2 dest = name <.&> src1 <&> op <&> src2 <&> storesOp <&> dest 140 | -------------------------------------------------------------------------------- /common/printing.v: -------------------------------------------------------------------------------- 1 | Require Import common.types. 2 | Require Import Coq.Strings.String. 3 | Require Import Coq.Strings.Ascii. 4 | Require Import ZArith. 5 | Require Import NPeano. 6 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. 7 | 8 | Import String. 9 | 10 | Set Implicit Arguments. 11 | Unset Strict Implicit. 12 | Unset Printing Implicit Defensive. 13 | 14 | Open Scope char_scope. 15 | Open Scope Z_scope. 16 | 17 | Definition ascii_of_Z (z : Z) : Ascii.ascii := 18 | match z with 19 | | 0 => "0" 20 | | 1 => "1" 21 | | 2 => "2" 22 | | 3 => "3" 23 | | 4 => "4" 24 | | 5 => "5" 25 | | 6 => "6" 26 | | 7 => "7" 27 | | 8 => "8" 28 | | _ => "9" 29 | end. 30 | 31 | Open Scope string_scope. 32 | 33 | Fixpoint format_Z_aux (fuel : nat) (z : Z) (acc : String.string) : String.string := 34 | match fuel with 35 | | O => acc 36 | | S fuel' => 37 | match Z.div_eucl z 10 with 38 | | (q, r) => 39 | match q with 40 | | Z0 => String.String (ascii_of_Z r) acc 41 | | _ => format_Z_aux fuel' q (String.String (ascii_of_Z r) acc) 42 | end 43 | end 44 | end. 45 | 46 | Definition format_Z z rest := 47 | match z with 48 | | Z0 => String.append "0" rest 49 | | Zpos _ => format_Z_aux (S (Z.to_nat (Z.log2 z))) z rest 50 | | Zneg _ => String.append "-" (format_Z_aux (S (Z.to_nat (Z.log2 z))) (Z.abs z) rest) 51 | end. 52 | 53 | (* ------------------------------------------------------------------- *) 54 | (* Append-list strings *) 55 | 56 | Open Scope string_scope. 57 | 58 | Definition sstring := string -> string. 59 | 60 | Definition ssempty : sstring := fun s => s. 61 | 62 | Definition ss (s : string) : sstring := 63 | fun s' => s ++ s'. 64 | 65 | Definition schar (c : ascii) : sstring := 66 | fun s => String c s. 67 | 68 | Definition ssappend (s1 s2 : sstring) : sstring := 69 | fun s => s1 (s2 s). 70 | 71 | Notation "x +++ y" := (ssappend x y) (right associativity, at level 60). 72 | 73 | Definition to_string (s : sstring) : string := s "". 74 | 75 | Definition ssconcat (sep : sstring) (s : seq sstring) : sstring := 76 | foldr (fun rest x => rest +++ sep +++ x) ssempty s. 77 | 78 | Definition sspace := ss " ". 79 | 80 | (* ------------------------------------------------------------------- *) 81 | 82 | Open Scope char_scope. 83 | Open Scope nat_scope. 84 | Definition natToDigit (n : nat) : ascii := 85 | match n with 86 | | 0 => "0" 87 | | 1 => "1" 88 | | 2 => "2" 89 | | 3 => "3" 90 | | 4 => "4" 91 | | 5 => "5" 92 | | 6 => "6" 93 | | 7 => "7" 94 | | 8 => "8" 95 | | _ => "9" 96 | end. 97 | 98 | Fixpoint writeNatAux (time n : nat) (acc : sstring) : sstring := 99 | let acc' := schar (natToDigit (n mod 10)) +++ acc in 100 | match time with 101 | | 0 => acc' 102 | | S time' => 103 | match n / 10 with 104 | | 0 => acc' 105 | | n' => writeNatAux time' n' acc' 106 | end 107 | end. 108 | 109 | Definition format_nat (n : nat) : sstring := 110 | writeNatAux n n ssempty. 111 | 112 | Open Scope string_scope. 113 | 114 | Definition format_binop (b : binop) := 115 | match b with 116 | | ADD => ss "ADD" 117 | | SUB => ss "SUB" 118 | | MUL => ss "MUL" 119 | | EQ => ss "EQ" 120 | | LEQ => ss "LEQ" 121 | | LEQU => ss "LEQU" 122 | | AND => ss "AND" 123 | | OR => ss "OR" 124 | | XOR => ss "XOR" 125 | | SHRU => ss "SHRU" 126 | | SHL => ss "SHL" 127 | end. 128 | 129 | Definition format_opcode (o : opcode) := 130 | match o with 131 | | NOP => ss "NOP" 132 | | CONST => ss "CONST" 133 | | MOV => ss "MOV" 134 | | BINOP b => format_binop b 135 | | LOAD => ss "LOAD" 136 | | STORE => ss "STORE" 137 | | JUMP => ss "JUMP" 138 | | BNZ => ss "BNZ" 139 | | JAL => ss "JAL" 140 | | JUMPEPC => ss "JUMPEPC" 141 | | ADDRULE => ss "ADDRULE" 142 | | GETTAG => ss "GETTAG" 143 | | PUTTAG => ss "PUTTAG" 144 | | HALT => ss "HALT" 145 | end. 146 | 147 | Class printing (mt : machine_types) := { 148 | format_word : mword mt -> sstring; 149 | format_reg : reg mt -> sstring; 150 | format_imm : imm mt -> sstring 151 | }. 152 | 153 | Section Printing. 154 | 155 | Context {mt : machine_types} 156 | {p : printing mt}. 157 | 158 | Definition format_reg_r (r : reg mt) := ss "r" +++ format_reg r. 159 | 160 | Definition format_instr (i : instr mt) := 161 | match i with 162 | | Nop => ss "Nop" 163 | | Const im r => ss "Const " +++ format_imm im +++ ss " " +++ format_reg_r r 164 | | Mov r1 r2 => ss "Mov " +++ format_reg_r r1 +++ ss " " +++ format_reg_r r2 165 | | Binop b r1 r2 r3 => format_binop b +++ ss " " +++ format_reg_r r1 +++ ss " " 166 | +++ format_reg_r r2 +++ ss " " +++ format_reg_r r3 167 | | Load r1 r2 => ss "Load " +++ format_reg_r r1 +++ ss " " +++ format_reg_r r2 168 | | Store r1 r2 => ss "Store " +++ format_reg_r r1 +++ ss " " +++ format_reg_r r2 169 | | Jump r1 => ss "Jump " +++ format_reg_r r1 170 | | Bnz r im => ss "Bnz " +++ format_reg_r r +++ ss " " +++ format_imm im 171 | | Jal r1 => ss "Jal " +++ format_reg_r r1 172 | | JumpEpc => ss "JumpEpc" 173 | | AddRule => ss "AddRule" 174 | | GetTag r1 r2 => ss "GetTag " +++ format_reg_r r1 +++ ss " " +++ format_reg_r r2 175 | | PutTag r1 r2 r3 => ss "PutTag " +++ format_reg_r r1 +++ ss " " +++ format_reg_r r2 +++ ss " " +++ format_reg_r r3 176 | | Halt => ss "Halt" 177 | end. 178 | 179 | End Printing. 180 | -------------------------------------------------------------------------------- /memory_safety/executable.v: -------------------------------------------------------------------------------- 1 | (** Executable semantics for abstract memory-safety machine *) 2 | 3 | From mathcomp Require Import 4 | ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype ssrint. 5 | From extructures Require Import ord fset fmap fperm. 6 | From CoqUtils Require Import word nominal. 7 | Require Import lib.utils. 8 | Require Import common.types memory_safety.classes memory_safety.abstract. 9 | 10 | Import DoNotation. 11 | 12 | Set Implicit Arguments. 13 | Unset Strict Implicit. 14 | Unset Printing Implicit Defensive. 15 | 16 | Module AbstractE. 17 | 18 | Section AbstractE. 19 | 20 | Local Open Scope fset_scope. 21 | 22 | Import Abstract. 23 | 24 | Variable mt : machine_types. 25 | Variable ops : machine_ops mt. 26 | Variable sr : syscall_regs mt. 27 | Variable addrs : memory_syscall_addrs mt. 28 | 29 | Local Notation state := (state mt). 30 | Local Notation pointer := [eqType of pointer mt]. 31 | Local Notation value := (value mt). 32 | Open Scope word_scope. 33 | Local Notation "x .+1" := (fst x, snd x + 1). 34 | 35 | Implicit Type m : memory mt. 36 | Implicit Type rs : registers mt. 37 | Implicit Type s : state. 38 | Implicit Type b : name. 39 | Implicit Type p : pointer. 40 | Implicit Type bs : {fset name}. 41 | Implicit Type v : value. 42 | Implicit Type pm : {fperm name}. 43 | 44 | Definition step s : option state := 45 | let: State m rs pc := s in 46 | match pc with 47 | | VPtr pc => 48 | do! i <- getv m pc; 49 | if i is VData i then 50 | do! i <- decode_instr i; 51 | match i with 52 | | Nop => Some (State m rs (VPtr pc.+1)) 53 | | Const n r => 54 | do! rs' <- updm rs r (VData (swcast n)); 55 | Some (State m rs' (VPtr pc.+1)) 56 | | Mov r1 r2 => 57 | do! v <- rs r1; 58 | do! rs' <- updm rs r2 v; 59 | Some (State m rs' (VPtr pc.+1)) 60 | | Binop f r1 r2 r3 => 61 | do! v1 <- rs r1; 62 | do! v2 <- rs r2; 63 | do! v3 <- lift_binop f v1 v2; 64 | do! rs' <- updm rs r3 v3; 65 | Some (State m rs' (VPtr pc.+1)) 66 | | Load r1 r2 => 67 | do! v1 <- rs r1; 68 | if v1 is VPtr p1 then 69 | do! v2 <- getv m p1; 70 | do! rs' <- updm rs r2 v2; 71 | Some (State m rs' (VPtr pc.+1)) 72 | else None 73 | | Store r1 r2 => 74 | do! v1 <- rs r1; 75 | if v1 is VPtr p1 then 76 | do! v2 <- rs r2; 77 | do! m' <- updv m p1 v2; 78 | Some (State m' rs (VPtr pc.+1)) 79 | else None 80 | | Jump r => 81 | do! v <- rs r; 82 | if v is VPtr p then 83 | Some (State m rs (VPtr p)) 84 | else None 85 | | Bnz r n => 86 | do! v <- rs r; 87 | if v is VData w then 88 | let off_pc' := pc.2 + (if w == 0 then 1 else swcast n) in 89 | Some (State m rs (VPtr (pc.1, off_pc'))) 90 | else None 91 | | Jal r => 92 | do! v <- rs r; 93 | do! rs' <- updm rs ra (VPtr pc.+1); 94 | Some (State m rs' v) 95 | | _ => None 96 | end 97 | else None 98 | | VData pc => 99 | if pc == addr Malloc then 100 | do! v1 <- rs syscall_arg1; 101 | if v1 is VData sz then 102 | let: (m', b) := malloc_fun m (blocks s) sz in 103 | do! rs' <- updm rs syscall_ret (VPtr (b, 0)); 104 | do! pc' <- rs ra; 105 | if pc' is VPtr pc' then 106 | Some (State m' rs' (VPtr pc')) 107 | else None 108 | else None 109 | else if pc == addr Free then 110 | do! v1 <- rs syscall_arg1; 111 | if v1 is VPtr p then 112 | do! m' <- free_fun m p.1; 113 | do! pc' <- rs ra; 114 | if pc' is VPtr pc' then 115 | Some (State m' rs (VPtr pc')) 116 | else None 117 | else None 118 | else if pc == addr Base then 119 | do! v1 <- rs syscall_arg1; 120 | if v1 is VPtr p then 121 | do! pc' <- rs ra; 122 | do! rs' <- updm rs syscall_ret (VPtr (p.1, 0)); 123 | if pc' is VPtr pc' then 124 | Some (State m rs' (VPtr pc')) 125 | else None 126 | else None 127 | else if pc == addr Eq then 128 | do! v1 <- rs syscall_arg1; 129 | do! v2 <- rs syscall_arg2; 130 | let v3 := VData (as_word (v1 == v2)) in 131 | do! rs' <- updm rs syscall_ret v3; 132 | do! pc' <- rs ra; 133 | if pc' is VPtr pc' then 134 | Some (State m rs' (VPtr pc')) 135 | else None 136 | else None 137 | end. 138 | 139 | Ltac solve_step_forward := 140 | rewrite /malloc_fun; 141 | intros; 142 | repeat match goal with 143 | | e : ?x = _ |- context[?x] => rewrite e /= 144 | | e : (_, _) = (_, _) |- _ => case: e=> ??; subst 145 | | |- _ => rewrite (inj_eq (@uniq_addr _ addrs)) /= 146 | end. 147 | 148 | Ltac solve_step_backward := 149 | repeat ( 150 | match goal with 151 | | p : Abstract.pointer _ |- _ => destruct p; simpl in * 152 | | e : (if (?pc == ?rhs) then _ else _) = Some _ |- _ => 153 | move: e; have [->|?] := altP (pc =P rhs); move=> e // 154 | | |- _ => match_inv 155 | end 156 | ). 157 | 158 | Lemma stepP s s' : Abstract.step s s' <-> step s = Some s'. 159 | Proof. 160 | split. 161 | (* -> *) 162 | by case: s s' / => /=; solve_step_forward. 163 | (* <- *) 164 | case: s=> m rs [pc|pc] /=; 165 | intros; solve_step_backward; [> once (econstructor; solve [eauto | reflexivity]) ..]. 166 | Qed. 167 | 168 | End AbstractE. 169 | 170 | End AbstractE. 171 | -------------------------------------------------------------------------------- /memory_safety/main.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype fintype seq ssrint. 2 | From extructures Require Import ord fmap. 3 | From CoqUtils Require Import hseq word nominal. 4 | 5 | Require Import lib.utils lib.word_utils. 6 | Require Import common.types. 7 | Require Import concrete.concrete. 8 | Require Import concrete.int_32. 9 | Require Import symbolic.symbolic. 10 | Require Import symbolic.int_32. 11 | Require Import symbolic.refinement_common. 12 | Require Import symbolic.backward. 13 | Require Import symbolic.rules. 14 | Require Import memory_safety.classes. 15 | Require Import memory_safety.symbolic. 16 | Require Import memory_safety.abstract. 17 | Require Import memory_safety.refinementAS. 18 | 19 | Set Implicit Arguments. 20 | Unset Strict Implicit. 21 | Unset Printing Implicit Defensive. 22 | 23 | Section Refinement. 24 | 25 | Let mt := concrete_int_32_mt. 26 | Existing Instance concrete_int_32_ops. 27 | Existing Instance concrete_int_32_ops_spec. 28 | 29 | Definition color_size := 13%nat. (*2^13 colors*) 30 | Definition color := [ordType of word color_size]. 31 | Definition inc_color (c : color) := (c + 1)%w. 32 | 33 | (* Encoding scheme 34 | 35 | type_bits = color_bits + 1 = 14 36 | TypeData -> 0 37 | TypePointer c -> c*2 + 1 38 | 39 | stag_bits = type_bits + color_bits + 3 = 29 40 | TagFree -> 0 41 | TagValue t -> (enc t)*4+1 42 | TagMemory c t -> c*2^(type_bits+3) + (enc t)*8 + 2 43 | *) 44 | 45 | Import Sym. 46 | 47 | Definition encode_type (ty : Sym.type) : word 14 := 48 | match ty with 49 | | TypeData => @wpack [:: 13; 1] [hseq 0%w; 0%w] 50 | | TypePointer c => @wpack [:: 13;1] [hseq as_word (val c); 1%w] 51 | end. 52 | 53 | Definition decode_type (cty : word 14) : option Sym.type := 54 | let: [hseq k; t] := @wunpack [:: 13; 1] cty in 55 | if t == 0%w then 56 | if k == 0%w then Some TypeData 57 | else None 58 | else if t == 1%w then 59 | Some (TypePointer (Name (val k))) 60 | else None. 61 | 62 | Definition encode_mtag (tg : Sym.mem_tag) : word 30 := 63 | match tg with 64 | | TagFree => @wpack [:: 13; 14; 3] [hseq 0; 0; 0]%w 65 | | TagMemory c ty => @wpack [:: 13;14;3] [hseq as_word (val c); encode_type ty; as_word 2]%w 66 | end. 67 | 68 | Import DoNotation. 69 | 70 | Definition decode_mtag (ctg : word 30) : option Sym.mem_tag := 71 | let: [hseq c;ty; m] := @wunpack [:: 13;14;3] ctg in 72 | if m == 0%w then 73 | if c == 0%w then 74 | if ty == 0%w then Some TagFree 75 | else None 76 | else None 77 | else 78 | if m == as_word 2 then 79 | do! cty <- decode_type ty; 80 | Some (TagMemory (Name (val c)) cty) 81 | else None. 82 | 83 | Instance enc: encodable mt Sym.ms_tags := { 84 | decode k m := fun (w : mword mt) => 85 | let: [hseq ut; w']%w := @wunpack [:: 30; 2] w in 86 | if w' == 0%w then None 87 | else 88 | match k return option (wtag Sym.ms_tags k) with 89 | | Symbolic.M => 90 | if w' == 1%w then 91 | do! ut <- decode_mtag ut; 92 | Some (@User Sym.ms_tags ut) 93 | else if w' == as_word 2 then 94 | Some (@Entry Sym.ms_tags tt) 95 | else None 96 | | Symbolic.P 97 | | Symbolic.R => 98 | let: [hseq ty; _]%w := @wunpack [:: 14; 16] ut in 99 | if w' == 1%w then 100 | do! ty <- decode_type ty; 101 | Some ty 102 | else None 103 | end 104 | }. 105 | Proof. 106 | - move=> * ?. reflexivity. 107 | - by move=> tk _; rewrite 2!wunpackS. 108 | Qed. 109 | 110 | Instance sp : Symbolic.params := Sym.sym_memory_safety mt. 111 | 112 | Context {monitor_invariant : @monitor_invariant _ _ enc} 113 | {syscall_addrs : @memory_syscall_addrs mt}. 114 | 115 | Inductive refine_state (ast : Abstract.state mt) (cst : Concrete.state mt) : Prop := 116 | | rs_intro : forall (sst : Symbolic.state mt) m, 117 | refinement_common.refine_state monitor_invariant (@Sym.memsafe_syscalls _ _ _ _) sst cst -> 118 | refinementAS.refine_state m ast sst -> 119 | refine_state ast cst. 120 | Hint Constructors refine_state. 121 | 122 | Hypothesis implementation_correct : 123 | monitor_code_bwd_correctness monitor_invariant (@Sym.memsafe_syscalls _ _ _ _). 124 | 125 | Lemma backwards_refinement_as ast m sst sst' : 126 | refinementAS.refine_state m ast sst -> 127 | exec (Symbolic.step (@Sym.memsafe_syscalls _ _ _ _)) sst sst' -> 128 | exists ast' m', 129 | exec (fun ast ast' => Abstract.step ast ast') ast ast' /\ 130 | refinementAS.refine_state m' ast' sst'. 131 | Proof. 132 | move => REF EXEC. 133 | elim: EXEC m ast REF => {sst sst'} [sst _ |sst sst' sst'' _ STEPS EXEC IH] m ast REF; first by eauto 7. 134 | have := @backward_simulation _ _ _ _ _ _ _ _ REF STEPS. 135 | intros (ast' & STEPA & m' & REF'). 136 | have := IH m' ast' REF'; eauto. 137 | intros (ast'' & m'' & EXECA & REF''). 138 | eauto 7. 139 | Qed. 140 | 141 | Lemma backwards_refinement (ast : Abstract.state mt) (cst cst' : Concrete.state mt) : 142 | refine_state ast cst -> 143 | exec (Concrete.step _ masks) cst cst' -> 144 | in_user cst' -> 145 | exists ast', 146 | exec (fun ast ast' => Abstract.step ast ast') ast ast' /\ 147 | refine_state ast' cst'. 148 | Proof. 149 | move => [sst m SC AS] EXECC INUSER. 150 | have := backward.backwards_refinement SC EXECC INUSER. 151 | move/(_ implementation_correct)=> [sst' EXECS SC']. 152 | have := backwards_refinement_as AS EXECS. 153 | intros (ast' & EXECA & GOOD' & AS'). by eauto 7. 154 | Qed. 155 | 156 | End Refinement. 157 | -------------------------------------------------------------------------------- /sealing/symbolic.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. 2 | From extructures Require Import ord fmap. 3 | From CoqUtils Require Import hseq word. 4 | 5 | Require Import lib.utils common.types. 6 | Require Import symbolic.symbolic sealing.classes. 7 | 8 | Import Symbolic. 9 | 10 | Set Implicit Arguments. 11 | Unset Strict Implicit. 12 | Unset Printing Implicit Defensive. 13 | 14 | Module Sym. 15 | 16 | Section WithClasses. 17 | 18 | Context {mt : machine_types} 19 | {ops : machine_ops mt} 20 | {opss : machine_ops_spec ops} 21 | {scr : syscall_regs mt} 22 | {ssa : @sealing_syscall_addrs mt}. 23 | 24 | Open Scope ord_scope. 25 | 26 | Class sealing_key := { 27 | key : ordType; 28 | max_key; 29 | inc_key : key -> key; 30 | ltb_inc : forall sk, sk < max_key -> sk < inc_key sk 31 | }. 32 | 33 | Context {sk : sealing_key}. 34 | 35 | (* We represent keys as tags on dummy values instead of payloads 36 | because this eliminates conversions from keys to words and back. *) 37 | Inductive stag := 38 | | DATA : stag 39 | | KEY : key -> stag 40 | | SEALED : key -> stag. 41 | 42 | Definition stag_eq t1 t2 := 43 | match t1, t2 with 44 | | DATA, DATA => true 45 | | KEY k1, KEY k2 46 | | SEALED k1, SEALED k2 => k1 == k2 47 | | _, _ => false 48 | end. 49 | 50 | Lemma stag_eqP : Equality.axiom stag_eq. 51 | Proof. 52 | by move=> [|k1|k1] [|k2|k2] /=; apply: (iffP idP) => // [/eqP->|[->]]. 53 | Qed. 54 | 55 | Definition stag_eqMixin := EqMixin stag_eqP. 56 | Canonical stag_eqType := Eval hnf in EqType stag stag_eqMixin. 57 | 58 | Definition stags := {| 59 | pc_tag_type := [eqType of unit]; 60 | reg_tag_type := [eqType of stag]; 61 | mem_tag_type := [eqType of stag]; 62 | entry_tag_type := [eqType of unit] 63 | |}. 64 | 65 | Section WithHSeqs. 66 | 67 | Definition sealing_handler (iv : ivec stags) : option (vovec stags (op iv)) := 68 | match iv with 69 | | IVec (OP NOP) tt DATA [hseq] => Some (@OVec stags NOP tt tt) 70 | | IVec (OP CONST) tt DATA [hseq _] => Some (@OVec stags CONST tt DATA) 71 | | IVec (OP MOV) tt DATA [hseq tsrc; _] => Some (@OVec stags MOV tt tsrc) 72 | | IVec (OP (BINOP o)) tt DATA [hseq DATA; DATA; _] => Some (@OVec stags (BINOP o) tt DATA) 73 | | IVec (OP LOAD) tt DATA [hseq DATA; tmem; _] => Some (@OVec stags LOAD tt tmem) 74 | | IVec (OP STORE) tt DATA [hseq DATA; tsrc; _] => Some (@OVec stags STORE tt tsrc) 75 | | IVec (OP JUMP) tt DATA [hseq DATA] => Some (@OVec stags JUMP tt tt) 76 | | IVec (OP BNZ) tt DATA [hseq DATA] => Some (@OVec stags BNZ tt tt) 77 | | IVec (OP JAL) tt DATA [hseq DATA; _] => Some (@OVec stags JAL tt DATA) 78 | | IVec SERVICE tt _ [hseq] => Some tt 79 | | IVec _ tt _ _ => None 80 | end. 81 | 82 | End WithHSeqs. 83 | 84 | Program Instance sym_sealing : params := { 85 | ttypes := stags; 86 | 87 | transfer := sealing_handler; 88 | 89 | internal_state := key (* next key to generate *) 90 | }. 91 | 92 | Import DoNotation. 93 | 94 | Definition mkkey (s : state mt) : option (state mt) := 95 | let 'State mem reg pc@pct key := s in 96 | if key < max_key then 97 | let key' := inc_key key in 98 | do! reg' <- updm reg syscall_ret 0%w@(KEY key); 99 | do! ret <- reg ra; 100 | match ret with 101 | | pc'@DATA => Some (State mem reg' (pc'@tt) key') 102 | | _ => None 103 | end 104 | else 105 | None. 106 | 107 | Definition seal (s : state mt) : option (state mt) := 108 | let 'State mem reg pc@pct next_key := s in 109 | match reg syscall_arg1, reg syscall_arg2 with 110 | | Some payload@DATA, Some _@(KEY key) => 111 | do! reg' <- updm reg syscall_ret payload@(SEALED key); 112 | do! ret <- reg ra; 113 | match ret with 114 | | pc'@DATA => Some (State mem reg' (pc'@tt) next_key) 115 | | _ => None 116 | end 117 | | _, _ => None 118 | end. 119 | 120 | Definition unseal (s : state mt) : option (state mt) := 121 | let 'State mem reg pc@pct next_key := s in 122 | match reg syscall_arg1, reg syscall_arg2 with 123 | | Some payload@(SEALED key), Some _@(KEY key') => 124 | if key == key' then 125 | do! reg' <- updm reg syscall_ret payload@DATA; 126 | do! ret <- reg ra; 127 | match ret with 128 | | pc'@DATA => Some (State mem reg' (pc'@tt) next_key) 129 | | _ => None 130 | end 131 | else None 132 | | _, _ => None 133 | end. 134 | 135 | Definition sealing_syscalls : syscall_table mt := 136 | [fmap (mkkey_addr, Syscall tt mkkey); 137 | (seal_addr, Syscall tt seal); 138 | (unseal_addr, Syscall tt unseal)]. 139 | 140 | Definition step := step sealing_syscalls. 141 | 142 | End WithClasses. 143 | 144 | (* BCP: Aren't there also some proof obligations that we need to satisfy? *) 145 | (* CH: You mean for the concrete-symbolic refinement? 146 | I expect those to appear when talking about that refinement, 147 | which we don't yet *) 148 | 149 | (* BCP: Yes, that's what I meant. I know we're not there yet, but I 150 | am wondering where we want to write them. Still confused about the 151 | modularization strategy for the whole codebase... *) 152 | (* CH: We will probably make a refinementCS.v file at some point, 153 | and I expect that to use any of Arthur's results we'll need 154 | to give this kind of details *) 155 | 156 | Notation memory mt := (Symbolic.memory mt sym_sealing). 157 | Notation registers mt := (Symbolic.registers mt sym_sealing). 158 | 159 | End Sym. 160 | -------------------------------------------------------------------------------- /lib/fmap_utils.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype. 2 | From extructures Require Import ord fset fmap. 3 | 4 | Set Implicit Arguments. 5 | Unset Strict Implicit. 6 | Unset Printing Implicit Defensive. 7 | 8 | Section Pointwise. 9 | 10 | Variables (T : ordType) (S1 S2 S3 : Type). 11 | 12 | Definition pointwise (P : S1 -> S2 -> Prop) 13 | (m1 : {fmap T -> S1}) 14 | (m2 : {fmap T -> S2}) : Prop := 15 | forall k, 16 | match m1 k, m2 k with 17 | | None , None => True 18 | | Some v1, Some v2 => P v1 v2 19 | | _ , _ => False 20 | end. 21 | 22 | Lemma refine_get_pointwise_inv : forall P m1 m2 v2 k, 23 | pointwise P m1 m2 -> 24 | m2 k = Some v2 -> 25 | exists v1, m1 k = Some v1 /\ P v1 v2. 26 | Proof. 27 | move=> P m1 m2 v2 k /(_ k) ref sget. 28 | rewrite {}sget in ref; move: ref. 29 | by case: (m1 k) => //; eauto. 30 | Qed. 31 | 32 | Lemma pointwise_none : forall P m1 m2 k, 33 | pointwise P m1 m2 -> 34 | (m2 k = None <-> m1 k = None). 35 | Proof. 36 | move=> P m1 m2 k /(_ k) ref. 37 | by split=> H; rewrite H in ref; move: ref; case: (getm _ _). 38 | Qed. 39 | 40 | Lemma pointwise_same_domain P m1 m2 : 41 | pointwise P m1 m2 -> 42 | domm m1 = domm m2. 43 | Proof. 44 | move=> H; apply/eq_fset=> k; move: {H} (H k); rewrite !mem_domm. 45 | destruct (getm m1 k) eqn:?; destruct (getm m2 k) eqn:?; tauto. 46 | Qed. 47 | 48 | Lemma refine_upd_pointwise2 P m1 m1' m2 m2' k v1 v2 : 49 | pointwise P m1 m2 -> 50 | P v1 v2 -> 51 | updm m1 k v1 = Some m1' -> 52 | updm m2 k v2 = Some m2' -> 53 | pointwise P m1' m2'. 54 | Proof. 55 | rewrite /updm; move=> pm1m2; move: (pm1m2 k). 56 | case: (m1 k) => [v1'|] //; case: (m2 k) => [v2'|] //= _ pv1v2 [<-] [<-] k'. 57 | move/(_ k'): pm1m2; rewrite !setmE. 58 | by case: (_ == _). 59 | Qed. 60 | 61 | Lemma refine_upd_pointwiseL P m1 m1' m2 k v1 v2 : 62 | pointwise P m1 m2 -> 63 | updm m1 k v1 = Some m1' -> 64 | P v1 v2 -> 65 | exists m2', updm m2 k v2 = Some m2' /\ 66 | pointwise P m1' m2'. 67 | Proof. 68 | rewrite /updm; move=> pm1m2; move: (pm1m2 k). 69 | case: (m2 k) => [v2'|] //; case: (m1 k) => [v1'|] //= _ [<-] pv1v2 . 70 | eexists; split; eauto=> k'. 71 | by move/(_ k'): pm1m2; rewrite !setmE; case: (_ == _). 72 | Qed. 73 | 74 | Lemma refine_upd_pointwiseR P m1 m2 m2' k v1 v2 : 75 | pointwise P m1 m2 -> 76 | updm m2 k v2 = Some m2' -> 77 | P v1 v2 -> 78 | exists m1', updm m1 k v1 = Some m1' /\ 79 | pointwise P m1' m2'. 80 | Proof. 81 | rewrite /updm; move=> pm1m2; move: (pm1m2 k). 82 | case: (m2 k) => [v2'|] //; case: (m1 k) => [v1'|] //= _ [<-] pv1v2. 83 | eexists; split; eauto=> k'. 84 | by move/(_ k'): pm1m2; rewrite !setmE; case: (_ == _). 85 | Qed. 86 | 87 | End Pointwise. 88 | 89 | Section FMapExtend. 90 | (* We show that if P km is closed under a key map transformation 91 | (e.g. extension) then so is any pointwise (P km) *) 92 | 93 | Variables K K1 K2 : ordType. 94 | Variables V1 V2 : Type. 95 | Variable P : {fmap K1 -> K2} -> V1 -> V2 -> Prop. 96 | Variable f : {fmap K1 -> K2} -> K1 -> K2 -> Prop. (* condition on key_map (e.g. freshness) *) 97 | Variable g : {fmap K1 -> K2} -> K1 -> K2 -> {fmap K1 -> K2}. (* key_map operation ( e.g. set) *) 98 | 99 | Hypothesis p_extend_map : forall km k1 k2 v1 v2, 100 | f km k1 k2 -> 101 | P km v1 v2 -> 102 | P (g km k1 k2) v1 v2. 103 | 104 | Lemma refine_extend_map km (m1 : {fmap K -> V1}) m2 k1 k2 : 105 | f km k1 k2 -> 106 | pointwise (P km) m1 m2 -> 107 | pointwise (P (g km k1 k2)) m1 m2. 108 | Proof. 109 | move => cond ref k. specialize (ref k). 110 | destruct (getm m1 k); destruct (getm m2 k) => //. 111 | by auto using p_extend_map. 112 | Qed. 113 | 114 | End FMapExtend. 115 | 116 | Section General. 117 | 118 | Variables (T : ordType) (S : Type). 119 | 120 | Implicit Type m : {fmap T -> S}. 121 | 122 | Lemma updm_defined m key val val' : 123 | m key = Some val -> 124 | exists m', 125 | updm m key val' = Some m'. 126 | Proof. rewrite /updm. move => -> /=. by eauto. Qed. 127 | 128 | Lemma updm_inv m key val' m' : 129 | updm m key val' = Some m' -> 130 | exists val, 131 | m key = Some val. 132 | Proof. 133 | rewrite /updm; case: (m key) => [val _|//]. 134 | by eauto. 135 | Qed. 136 | 137 | Lemma getm_upd_eq m m' key val : 138 | updm m key val = Some m' -> 139 | m' key = Some val. 140 | Proof. 141 | rewrite /updm; case: (m key) => [val' [<-]|//]. 142 | by rewrite setmE eqxx. 143 | Qed. 144 | 145 | Lemma getm_upd_neq m m' (key key' : T) (val : S) : 146 | key' <> key -> 147 | updm m key val = Some m' -> 148 | m' key' = m key'. 149 | Proof. 150 | rewrite /updm; case: (m key) => [val'|] //= NEQ [<-]. 151 | by rewrite setmE (introF eqP NEQ). 152 | Qed. 153 | 154 | Lemma getm_upd m m' k v : 155 | updm m k v = Some m' -> 156 | forall k', m' k' = if k' == k then Some v else m k'. 157 | Proof. 158 | move=> Hupd k'. 159 | have [-> {k'}|Hneq] := k' =P k. 160 | by rewrite (getm_upd_eq Hupd). 161 | by rewrite (getm_upd_neq Hneq Hupd). 162 | Qed. 163 | 164 | Lemma filter_domains (f : S -> bool) m m' : 165 | domm m = domm m' -> 166 | (forall k, match getm m k, getm m' k with 167 | | Some v, Some v' => f v = f v' 168 | | None, None => True 169 | | _, _ => False 170 | end) -> 171 | domm (filterm (fun _ v => f v) m) = 172 | domm (filterm (fun _ v => f v) m') :> {fset T}. 173 | Proof. 174 | move => SAME E; apply/eq_fset=> k; rewrite !mem_domm; do! rewrite filtermE /=. 175 | case GET: (getm m k) (E k) => [v|] {E} E; 176 | case GET': (getm m' k) E => [v'|] E //=. 177 | by rewrite E; case: (f v'). 178 | Qed. 179 | 180 | End General. 181 | 182 | Lemma pointwise_sym (T : ordType) S (R : S -> S -> Prop) : 183 | (forall x y, R x y -> R y x) -> 184 | (forall m1 m2 : {fmap T -> S}, pointwise R m1 m2 -> pointwise R m2 m1). 185 | Proof. 186 | move=> R_sym m1 m2 m1m2 k. 187 | move: (m1m2 k). 188 | case: (m1 k) (m2 k) => [v1|] [v2|] //=. 189 | exact: R_sym. 190 | Qed. 191 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: coq clean 2 | 3 | coq: Makefile.coq 4 | $(MAKE) -f Makefile.coq 5 | 6 | Makefile.coq: _CoqProject 7 | coq_makefile -f _CoqProject -o Makefile.coq 8 | 9 | clean: 10 | rm -f */*.vo */*.v.d */*.glob */*~ */.#* Makefile.coq 11 | rm -f */*/*.vo */*/*.v.d */*/*.glob 12 | $(MAKE) -C os clean 13 | 14 | test: coq 15 | $(MAKE) -C sealing runtest 16 | 17 | LIB=lib/*.v 18 | COMMON=common/*.v 19 | CONCRETE=concrete/*.v 20 | SYMBOLIC=symbolic/*.v 21 | SHARED=$(LIB) $(COMMON) $(CONCRETE) $(SYMBOLIC) 22 | 23 | MEMSAFE=memory_safety/*.v 24 | SEALING=sealing/*.v 25 | COMPART=compartmentalization/*.v 26 | CFI =cfi/*.v 27 | SPECIF=$(MEMSAFE) $(SEALING) $(COMPART) $(CFI) 28 | 29 | # Further breaking it down for symbolic dir 30 | SYM_DEF=symbolic/symbolic.v symbolic/exec.v 31 | SYM_CON_PROOF=symbolic/backward.v symbolic/forward.v symbolic/refinement_common.v 32 | HANDLER=symbolic/rules.v symbolic/fault_handler.v symbolic/int_32.v 33 | 34 | REGEXP="s/([[:digit:]]+) ([[:digit:]]+)/scale=1; x=\(\1+\2\)\/1000; if(x<1) print 0; x/p" 35 | PROCESS=grep total | tr -s ' ' | cut -d ' ' -f 2-3 | sed -rn $(REGEXP) | bc | tr '\n' 'k' 36 | 37 | bc: 38 | @echo -n -e "%The shared/common/framework part\n\\\\newcommand{\\SHARED}{" 39 | @coqwc $(SHARED) | $(PROCESS) 40 | @echo -n -e "}\n%The policy-specific parts\n\\\\newcommand{\\SPECIF}{" 41 | @coqwc $(SPECIF) | $(PROCESS) 42 | @echo -n -e "}\n%The total\n\\\\newcommand{\\TOTAL}{" 43 | @coqwc $(SHARED) $(SPECIF) | $(PROCESS) 44 | @echo "}" 45 | 46 | @echo "%%%%%%%%%%%%%%%%%%%%%%%%%%%" 47 | @echo -n -e "%Generic libraries\n\\\\newcommand{\\LIB}{" 48 | @coqwc $(LIB) | $(PROCESS) 49 | @echo -n -e "}\n%Shared syntax and lemma used by all machines\n\\\\newcommand{\\COMMON}{" 50 | @coqwc $(COMMON) | $(PROCESS) 51 | @echo -n -e "}\n%Concrete machine\n\\\\newcommand{\\CONCRETE}{" 52 | @coqwc $(CONCRETE) | $(PROCESS) 53 | @echo -n -e "}\n%Everything else (symbolic dir)\n\\\\newcommand{\\SYMBOLIC}{" 54 | @coqwc $(SYMBOLIC) | $(PROCESS) 55 | @echo "}" 56 | 57 | @echo "%%%%%%%%%%%%%%%%%%%%%%%%%%%" 58 | @echo -n -e "%Memory safety\n\\\\newcommand{\\MEMSAFE}{" 59 | @coqwc $(MEMSAFE) | $(PROCESS) 60 | @echo -n -e "}\n%Dynamic sealing\n\\\\newcommand{\\SEALING}{" 61 | @coqwc $(SEALING) | $(PROCESS) 62 | @echo -n -e "}\n%Compartmentalization\n\\\\newcommand{\\COMPART}{" 63 | @coqwc $(COMPART) | $(PROCESS) 64 | @echo -n -e "}\n%Control Flow Integrity\n\\\\newcommand{\\CFI}{" 65 | @coqwc $(CFI) | $(PROCESS) 66 | @echo "}" 67 | 68 | @echo "%%%%%%%%%%%%%%%%%%%%%%%%%%%" 69 | @echo -n -e "%The symbolic machine definition\n\\\\newcommand{\\SYMDEF}{" 70 | @coqwc $(SYM_DEF) | $(PROCESS) 71 | @echo -n -e "}\n%The symbolic-concrete refinement proof\n\\\\newcommand{\\SYMCONPROOF}{" 72 | @coqwc $(SYM_CON_PROOF) | $(PROCESS) 73 | @echo -n -e "}\n%The generic fault handler (or something like that)\n\\\\newcommand{\\HANDLER}{" 74 | @coqwc $(HANDLER) | $(PROCESS) 75 | @echo "}" 76 | 77 | EXCLUDE=--exclude=testing --exclude=.gitignore --exclude=compartmentalization/global-hint.el 78 | 79 | dist: clean 80 | rm -f rm ../micropolicies.tar.gz 81 | tar czvf ../micropolicies.tar.gz . --transform 's/^\./micropolicies/' $(EXCLUDE) 82 | 83 | DIR=../micropolicies-coq-anon 84 | COQ_UTILS=../coq-utils 85 | 86 | dist-anon: clean 87 | rm -dfr rm $(DIR) ../micropolicies-coq-anon.tar.gz 88 | cp -R . $(DIR) 89 | rm -dfr $(DIR)/.git 90 | cd $(COQ_UTILS); make clean 91 | cp -R $(COQ_UTILS) $(DIR) 92 | rm -dfr $(DIR)/coq-utils/.git 93 | perl -0777 -i -pe 's/Copyright.*Permission/Copyright Anonymized\n\nPermission/igs' $(DIR)/coq-utils/LICENSE 94 | perl -0777 -i -pe 's/Copyright.*Permission/Copyright Anonymized\n\nPermission/igs' $(DIR)/LICENSE 95 | perl -0777 -i -pe 's/Description.*Prerequisites/Prerequisites/igs' $(DIR)/README.md 96 | perl -0777 -i -pe 's/The CoqUtils library \(https.*coq-utils\)/The CoqUtils library \(included in coq-utils subdir\)/igs' $(DIR)/README.md 97 | # Next command doesn't work for nested comments, please don't add any 98 | find $(DIR) -name '*.v' -exec perl -0777 -i -pe 's/\(\*.*?\*\)//igs' {} \; 99 | cd $(DIR); tar czvf ../micropolicies-coq-anon.tar.gz . --transform 's/^\./micropolicies-coq-anon/' $(EXCLUDE) 100 | 101 | coqide: 102 | coqide -R . MicroPolicies 103 | 104 | # The target `extract-DIR' extracts the Coq code in `DIR' to Haskell code in 105 | # `DIR/extracted/', using the file `DIR/extraction.v' and any extra code in 106 | # `DIR/extra'. The `DIR/extracted.v' file should probably just import 107 | # `extraction/extraction.v' and another library `LIB', and then `Recursive 108 | # Extraction Library LIB'. Don't pass `extract-DIR' `DIR's that are nested 109 | # (i.e., that aren't exactly one level deep) or that contain "weird" characters 110 | # (things that would break a regular expression, or an `@'). 111 | # 112 | # This can also be made available from those subdirectories where one wants to 113 | # extract, which is probably a good idea. 114 | # 115 | # Here's what `extract-DIR' does: 116 | # 1. Makes sure the postprocessor exists. 117 | # 2. Wipes out any past results of compiling the extraction file, letting us 118 | # use `make' in step 3. 119 | # 3. Uses the Coq makefile to print out the Coq compilation command, then 120 | # fix it up so that: 121 | # (a) The references to `.' for the root directory become `..'. 122 | # (b) The references to `DIR/' (as in `DIR/extraction.vo') become `./'. 123 | # The result is stored in $(TEMP). 124 | # 4. Runs the command from step 3 inside the directory DIR, deleting $(TEMP) 125 | # if it failed. 126 | # 5. Delete $(TEMP) and the results of compiling the extraction file. 127 | # 6. Postprocesses the extracted files into an `extracted' subdirectory of 128 | # `DIR', using extra code from an `extra' subdirectory. 129 | extract-%: TEMP:=$(shell mktemp --tmpdir extraction.XXX) 130 | extract-%: coq 131 | $(MAKE) -C extraction/postprocess 132 | rm -f $*/extraction.vo $*/extraction.glob 133 | $(MAKE) -nf Makefile.coq $*/extraction.vo \ 134 | | sed -r 's/ \. / .. /; s@'$*'/@./@' \ 135 | > $(TEMP) 136 | @ # This sed script fixes the `coqc' command to work from inside the given 137 | @ # directory: `.' (the root) becomes `..', and `dir/' becomes './'. 138 | cd $* && $(SHELL) $(TEMP) || rm -f $(TEMP) 139 | rm -f $(TEMP) $*/extraction.vo $*/extraction.glob 140 | extraction/postprocess/postprocess $* $*/extracted $*/extra 141 | -------------------------------------------------------------------------------- /os/haskell/Haskell/Assembler.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds, FlexibleContexts, TupleSections #-} 2 | 3 | {-| 4 | Module : Haskell.Assembler 5 | Description : Utilities for assembling a symbolic machine 6 | Copyright : © 2015 Antal Spector-Zabusky 7 | License : BSD3 8 | Maintainer : Antal Spector-Zabusky 9 | Stability : experimental 10 | Portability : GHC only 11 | 12 | This module provides the 'Assembler' monad from "Haskell.Monad.Trans.Assembler" 13 | with utilities for working with the symbolic machine from "Haskell.Machine": 14 | ways of writing instructions, working with immediates vs. machine words, etc. 15 | The 'SymAssembler' type provides the appropriate type parameters to 'Assembler'. 16 | -} 17 | 18 | module Haskell.Assembler ( 19 | module Haskell.Monad.Assembler, 20 | MonadSymAssembler, SymAssemblerT, SymAssembler, 21 | instr, instrs, 22 | nop, const_, mov, binop, load, store, jump, bnz, jal, 23 | jumpEpc, addRule, getTag, putTag, 24 | halt, 25 | tryMWordImm, 26 | immediateTooBigMsg, addrToImm, addrToImm', 27 | hereImm, reserveImm 28 | ) where 29 | 30 | import Control.Arrow 31 | import Control.Applicative hiding (Const(..)) 32 | import Control.Monad 33 | import Control.Monad.Fix 34 | 35 | import Haskell.Machine 36 | 37 | import Haskell.Monad.Assembler 38 | 39 | -- |A 'MonadAssembler' monad class/constraint for the symbolic machine. Errors 40 | -- are 'String's; pointers and words are both 'MWord's. 41 | type MonadSymAssembler = MonadAssembler String MWord MWord 42 | 43 | -- |An 'AssemblerT' monad transformer for the symbolic machine. Errors are 44 | -- 'String's; pointers and words are both 'MWord's. 45 | type SymAssemblerT = AssemblerT String MWord MWord 46 | 47 | -- |An 'Assembler' monad for the symbolic machine. Errors are 'String's; 48 | -- pointers and words are both 'MWord's. 49 | type SymAssembler = Assembler String MWord MWord 50 | 51 | -- |Encodes and writes a single instruction to the instruction stream. 52 | instr :: MonadSymAssembler m => Instr -> m () 53 | instr = asmWord . encodeInstr 54 | 55 | -- |Encodes and writes a list of instructions to the instruction stream. 56 | instrs :: MonadFix m => [Instr] -> SymAssemblerT m () 57 | instrs = asmWords . map encodeInstr 58 | 59 | nop :: MonadSymAssembler m => m () -- ^Write a 'Nop' instruction to the instruction stream 60 | const_ :: MonadSymAssembler m => Imm -> Reg -> m () -- ^Write a 'Const' instruction to the instruction stream 61 | mov :: MonadSymAssembler m => Reg -> Reg -> m () -- ^Write a 'Mov' instruction to the instruction stream 62 | binop :: MonadSymAssembler m => Binop -> Reg -> Reg -> Reg -> m () -- ^Write a 'Binop' instruction to the instruction stream 63 | load :: MonadSymAssembler m => Reg -> Reg -> m () -- ^Write a 'Load' instruction to the instruction stream 64 | store :: MonadSymAssembler m => Reg -> Reg -> m () -- ^Write a 'Store' instruction to the instruction stream 65 | jump :: MonadSymAssembler m => Reg -> m () -- ^Write a 'Jump' instruction to the instruction stream 66 | bnz :: MonadSymAssembler m => Reg -> Imm -> m () -- ^Write a 'Bnz' instruction to the instruction stream 67 | jal :: MonadSymAssembler m => Reg -> m () -- ^Write a 'Jal' instruction to the instruction stream 68 | jumpEpc :: MonadSymAssembler m => m () -- ^Write a 'JumpEpc' instruction to the instruction stream 69 | addRule :: MonadSymAssembler m => m () -- ^Write an 'AddRule' instruction to the instruction stream 70 | getTag :: MonadSymAssembler m => Reg -> Reg -> m () -- ^Write a 'GetTag' instruction to the instruction stream 71 | putTag :: MonadSymAssembler m => Reg -> Reg -> Reg -> m () -- ^Write a 'PutTag' instruction to the instruction stream 72 | halt :: MonadSymAssembler m => m () -- ^Write a 'Halt' instruction to the instruction stream 73 | 74 | nop = instr Nop 75 | const_ = (instr .) . Const 76 | mov = (instr .) . Mov 77 | binop = (((instr .) .) .) . Binop 78 | load = (instr .) . Load 79 | store = (instr .) . Store 80 | jump = instr . Jump 81 | bnz = (instr .) . Bnz 82 | jal = instr . Jal 83 | jumpEpc = instr JumpEpc 84 | addRule = instr AddRule 85 | getTag = (instr .) . GetTag 86 | putTag = ((instr .) .) . PutTag 87 | halt = instr Halt 88 | 89 | -- |@tryMWordImm fImm fWord w@ checks if the word @w@ fits into an immediate. 90 | -- If it does, then 'fImm' is called on the resulting immediate; if it does not, 91 | -- 'fWord' is called on the original word. 92 | tryMWordImm :: (Imm -> a) -> (MWord -> a) -> MWord -> a 93 | tryMWordImm fImm fWord w = 94 | let n = toInteger w 95 | in if n <= toInteger (maxBound :: Imm) 96 | then fImm $ imm n 97 | else fWord w 98 | 99 | -- |An error message to display when the given word is too big to fit into an 100 | -- immediate. 101 | immediateTooBigMsg :: MWord -> String 102 | immediateTooBigMsg a = "Address " ++ show a ++ " is too big to be immediate." 103 | 104 | -- |Convert a word into an immediate, failing /immediately/ if the word was out 105 | -- of range. Do not use with time-traveling information (such as the result of 106 | -- 'reserve'). 107 | addrToImm :: MonadSymAssembler m => MWord -> m Imm 108 | addrToImm = tryMWordImm pure (asmError . immediateTooBigMsg) 109 | 110 | -- |Convert a word into an immediate, with a /delayed/ failure if the word was 111 | -- out of range. This function is safe to use with time-traveling information 112 | -- (such as the result of 'reserve'). 113 | addrToImm' :: MonadSymAssembler m => MWord -> m Imm 114 | addrToImm' = uncurry (<$) . second asmDelayedError 115 | . tryMWordImm (,Nothing) 116 | (fromIntegral &&& Just . immediateTooBigMsg) 117 | 118 | -- |Return the current instruction address as an immediate (see also 'here'); 119 | -- fails immediately if the current instruction address does not fit into an 120 | -- immediate. 121 | hereImm :: MonadSymAssembler m => m Imm 122 | hereImm = addrToImm =<< here 123 | 124 | -- |Reserve some data and return its address as an immediate (see also 125 | -- 'reserve'); causes a delayed failure if the current instruction address does 126 | -- not fit into an immediate. 127 | reserveImm :: MonadSymAssembler m => MWord -> m Imm 128 | reserveImm = addrToImm' <=< reserve 129 | -------------------------------------------------------------------------------- /compartmentalization/global-hint.el: -------------------------------------------------------------------------------- 1 | ;;; global-hint.el --- Copy all marked `Hint' lines in a Coq script 2 | 3 | ;; Author: Antal Spector-Zabusky 4 | ;; Created: June 6, 2014, 16:03 5 | ;; Keywords: languages tools 6 | 7 | ;;; Commentary: 8 | ;; TL;DR: Write "(*Global*) Hint", run "M-x coqgh-collect-global-hints". 9 | ;; 10 | ;; Coq 8.4 doesn't have support for "Global Hint ..." declarations, so all hints 11 | ;; provided inside a section are lost when it's closed. This is annoying if 12 | ;; you're building up a database of hints to be used with "auto" *and* that 13 | ;; database builds on itself. Thus, this Emacs script lets you fake it. 14 | ;; 15 | ;; When you want a command of the form "Global Hint ...", instead write 16 | ;; "(*Global*) Hint" (spaces around all these words are optional, but the line 17 | ;; must only contain the hint). Then, invoke "M-x coqgh-collect-global-hints", 18 | ;; and all the marked hints will be copied to a separate section delimited by 19 | ;; the lines "(* Start globalized hint section *)" and 20 | ;; "(* End globalized hint section *)". If you want to have multiple such 21 | ;; blocks (say, if you have multiple sections), use "M-x 22 | ;; coqgh-empty-hint-section". (While `coqgh-collect-global-hints' tries to put 23 | ;; the block in the right place, it might end up back inside a section or 24 | ;; outside the module definition -- feel free to move it, or use 25 | ;; `coqgh-empty-hint-section'. This time, however, spaces matter.) 26 | ;; 27 | ;; It's fine to move these globalized hint sections around or even split them up 28 | ;; (so long as you preserve the starting and ending comments). However, don't 29 | ;; bother editing these sections manually if you plan on running 30 | ;; `coqgh-collect-global-hints' again; running it will always overwrite the 31 | ;; contents of all such delimited sections. 32 | 33 | ;;; Code: 34 | 35 | (require 'rx) 36 | 37 | (defun coqgh--comment (rx-form &optional as-string) 38 | "Wrap an RX-FORM to match its contents inside a Coq comment. 39 | RX-FORM is a regular expression in sexp form (like for `rx'). 40 | AS-STRING non-nil means return a string (not a sexp form)." 41 | (let ((form `(: "(*" (* space) ,rx-form (* space) "*)"))) 42 | (if as-string (rx-to-string form) form))) 43 | 44 | (defconst coqgh-hint-line 45 | (rx-to-string 46 | `(: bol (* space) ,(coqgh--comment "Global") (* space) 47 | (group "Hint" (* nonl) eol))) 48 | "The regular expression that matches a faux-global \"Hint\" line. 49 | 50 | Just prefix \"Hint\" with \"(*Global*)\", and you'll be fine.") 51 | 52 | (defconst coqgh--hint-section-descriptor 53 | "globalized hint section" 54 | "The string used in global hint section delimiters.") 55 | 56 | (defun coqgh--hint-section-delimiter (prefix) 57 | "Return the globalized hint section delimiter starting with PREFIX. 58 | This is a string, not a regular expression." 59 | (concat "(* " prefix " " coqgh--hint-section-descriptor " *)")) 60 | 61 | (defconst coqgh-hint-section-start 62 | (coqgh--hint-section-delimiter "Start") 63 | "The string that starts a globalized hint section.") 64 | 65 | (defconst coqgh-hint-section-end 66 | (coqgh--hint-section-delimiter "End") 67 | "The string that ends a globalized hint section.") 68 | 69 | (defconst coqgh-emacs-line 70 | "(* Can be updated automatically by an Emacs script; see `global-hint.el' *)" 71 | "A string saying the following stuff is automatically generated.") 72 | 73 | (defun coqgh--whole-line-string (string &optional as-string) 74 | "Return a regular expression form matching a line containing STRING. 75 | The line must contain only STRING (and leading/trailing spaces). 76 | AS-STRING non-nil means return a string (not a sexp form)." 77 | (let ((form `(: bol (* space) ,string (* space) eol))) 78 | (if as-string (rx-to-string form) form))) 79 | 80 | (defun coqgh--insert-hint-section (hints &optional new) 81 | "Insert a globalized hint section containing HINTS at point. 82 | NEW non-nil means to insert a new section with start/end lines. 83 | This function changes the point and the match data." 84 | (message "Inserting%s hint section" (if new " new" "")) 85 | (if new 86 | (progn (insert coqgh-emacs-line) 87 | (newline-and-indent) 88 | (insert coqgh-hint-section-start) 89 | (newline-and-indent)) 90 | (delete-region 91 | (point) 92 | (save-excursion 93 | (re-search-forward (coqgh--whole-line-string coqgh-hint-section-end t)) 94 | (match-beginning 0)))) 95 | (dolist (hint hints) 96 | (insert hint) 97 | (newline-and-indent)) 98 | (when new 99 | (insert coqgh-hint-section-end) 100 | (newline-and-indent))) 101 | 102 | (defun coqgh-collect-global-hints () 103 | "Copy \"(*Global*) Hint\" lines outside their sections." 104 | (interactive) 105 | (save-excursion 106 | (save-match-data 107 | (let ((case-fold-search nil) 108 | hints) 109 | (goto-char (point-min)) 110 | ;; Find all the hints/sections 111 | (while (re-search-forward (rx-to-string 112 | `(| (group ,(coqgh--whole-line-string 113 | coqgh-hint-section-start)) 114 | (group (regexp ,coqgh-hint-line)))) 115 | nil t) 116 | ;; The first group is the section header, the second group is the 117 | ;; *whole* hint line, and the *third* group is the hint line without 118 | ;; the "(*Global*)" prefix 119 | (let ((section-start (match-string 1)) (hint (match-string 3))) 120 | (if hint 121 | (progn 122 | (push hint hints) 123 | (message "Found %s" hint)) 124 | ;; Skip the section header 125 | (goto-char (match-end 1)) 126 | (forward-line) 127 | ;; Insert the hints 128 | (coqgh--insert-hint-section (nreverse hints)) 129 | ;; Reset the hints 130 | (setq hints nil)))) 131 | ;; Were there any leftover hints? 132 | (when hints 133 | ;; Insert a new hint section at the end of the buffer 134 | (goto-char (point-max)) 135 | (newline-and-indent) 136 | (coqgh--insert-hint-section (nreverse hints) t)) 137 | (message "Done collecting global hints"))))) 138 | 139 | (defun coqgh-empty-hint-section () 140 | "Create a new empty globalized hint section at point." 141 | (interactive) 142 | (save-excursion 143 | (save-match-data 144 | (coqgh--insert-hint-section nil t)))) 145 | 146 | (provide 'global-hint) 147 | 148 | ;;; global-hint.el ends here 149 | -------------------------------------------------------------------------------- /cfi/concrete.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. 2 | From extructures Require Import ord fmap. 3 | From CoqUtils Require Import word. 4 | 5 | Require Import lib.utils lib.fmap_utils. 6 | Require Import common.types. 7 | Require Import concrete.concrete. 8 | Require Import symbolic.symbolic. 9 | Require Import cfi.symbolic. 10 | Require Import cfi.property. 11 | Require Import cfi.rules. 12 | Require Import cfi.classes. 13 | Require Import symbolic.rules. 14 | Require Import symbolic.refinement_common. 15 | 16 | Set Implicit Arguments. 17 | Unset Strict Implicit. 18 | Unset Printing Implicit Defensive. 19 | 20 | Module Conc. 21 | Section ConcreteSection. 22 | 23 | Context {mt : machine_types} 24 | {ops : machine_ops mt} 25 | {ids : cfi_id mt} 26 | {e : rules.fencodable mt cfi_tags}. 27 | 28 | Variable cfg : id -> id -> bool. 29 | 30 | Definition valid_jmp := classes.valid_jmp cfg. 31 | 32 | (*allow attacker to change only things tagged USER DATA! all the rest should be equiv*) 33 | 34 | 35 | Definition no_violation (cst : Concrete.state mt) := 36 | let '(Concrete.State mem _ _ pc@tpc _) := cst in 37 | (forall i cti ti src, 38 | getm mem pc = Some i@cti -> 39 | @fdecode _ _ e Symbolic.M cti = Some (User ti) -> 40 | @fdecode _ _ e Symbolic.P tpc = Some (INSTR (Some src)) -> 41 | exists dst, 42 | ti = INSTR (Some dst) /\ cfg src dst) /\ 43 | (forall i cti ti src, 44 | getm mem pc = Some i@cti -> 45 | @fdecode _ _ e Symbolic.M cti = Some (Entry ti) -> 46 | @fdecode _ _ e Symbolic.P tpc = Some (INSTR (Some src)) -> 47 | exists dst, 48 | ti = INSTR (Some dst) /\ cfg src dst). 49 | 50 | Definition cast k : Symbolic.tag_type cfi_tags k -> cfi_tag := 51 | match k return Symbolic.tag_type cfi_tags k -> cfi_tag with 52 | | Symbolic.M => fun t => t 53 | | _ => fun t => t 54 | end. 55 | 56 | Definition cast' k (t : cfi_tag) : Symbolic.tag_type cfi_tags k := 57 | match k with 58 | | Symbolic.M => t 59 | | _ => t 60 | end. 61 | 62 | (*Defined in terms of atom_equiv for symbolic tags*) 63 | (* TODO: as a sanity check, please prove reflexivity for this and 64 | the other attacker relations. That will ensure that the attacker 65 | can at least keep things the same. *) 66 | Inductive atom_equiv k (a : atom (mword mt) (mword mt)) (a' : atom (mword mt) (mword mt)) : Prop := 67 | | user_equiv : forall v v' ct ut ct' ut', 68 | a = v@ct -> 69 | @fdecode _ _ e k ct = Some (wtag_of_tag ut) -> 70 | a' = v'@ct' -> 71 | @fdecode _ _ e k ct' = Some (wtag_of_tag ut') -> 72 | Sym.atom_equiv v@(cast ut) v'@(cast ut') -> 73 | atom_equiv k a a' 74 | | any_equiv : (~ exists ut, @fdecode _ _ e k (taga a) = Some (wtag_of_tag ut)) -> 75 | a = a' -> 76 | atom_equiv k a a'. 77 | 78 | Definition equiv (mem mem' : Concrete.memory mt) := 79 | pointwise (atom_equiv Symbolic.M) mem mem'. 80 | 81 | Definition reg_equiv (regs : Concrete.registers mt) (regs' : Concrete.registers mt) := 82 | forall r, exists x x', 83 | getm regs r = Some x /\ 84 | getm regs' r = Some x' /\ 85 | atom_equiv Symbolic.R x x'. 86 | 87 | Inductive step_a : Concrete.state mt -> 88 | Concrete.state mt -> Prop := 89 | | step_attack : forall mem reg cache pc tpc epc mem' reg' 90 | (INUSER: @fdecode _ _ e Symbolic.P tpc) 91 | (REQUIV: reg_equiv reg reg') 92 | (MEQUIV: equiv mem mem'), 93 | step_a (Concrete.State mem reg cache pc@tpc epc) 94 | (Concrete.State mem' reg' cache pc@tpc epc). 95 | 96 | Local Notation "x .+1" := (x + 1)%w. 97 | Local Open Scope word_scope. 98 | 99 | Definition csucc (st : Concrete.state mt) (st' : Concrete.state mt) : bool := 100 | let pc_s := vala (Concrete.pc st) in 101 | let pc_s' := vala (Concrete.pc st') in 102 | if in_monitor st || in_monitor st' then true else 103 | match (getm (Concrete.mem st) pc_s) with 104 | | Some i => 105 | match (@fdecode _ _ e Symbolic.M (taga i)) with 106 | | Some (User (INSTR (Some src))) => 107 | match decode_instr (vala i) with 108 | | Some (Jump r) 109 | | Some (Jal r) => 110 | match (getm (Concrete.mem st) pc_s') with 111 | | Some i' => 112 | match (@fdecode _ _ e Symbolic.M (taga i')) with 113 | | Some (User (INSTR (Some dst))) => 114 | cfg src dst 115 | | Some (Entry (INSTR (Some dst))) => 116 | is_nop (vala i') && cfg src dst 117 | | _ => false 118 | end 119 | | _ => false 120 | end 121 | | Some (Bnz r imm) => 122 | (pc_s' == pc_s .+1) || (pc_s' == pc_s + swcast imm) 123 | | None => false 124 | | _ => pc_s' == pc_s .+1 125 | end 126 | | Some (User (INSTR None)) => 127 | match decode_instr (vala i) with 128 | | Some (Jump r) 129 | | Some (Jal r) => 130 | false 131 | | Some (Bnz r imm) => 132 | (pc_s' == pc_s .+1) || (pc_s' == pc_s + swcast imm) 133 | | None => false 134 | | _ => pc_s' == pc_s .+1 135 | end 136 | (* this says that if cst,cst' is in user mode then it's 137 | not sensible to point to monitor memory*) 138 | | Some (User DATA) 139 | | Some (Entry _) 140 | | None => false 141 | end 142 | | None => false 143 | end. 144 | 145 | Instance sp : Symbolic.params := Sym.sym_cfi cfg. 146 | 147 | Variable mi : refinement_common.monitor_invariant. 148 | 149 | Variable stable : Symbolic.syscall_table mt. 150 | 151 | (* This is basically the initial_refine assumption on preservation *) 152 | Definition cinitial (cs : Concrete.state mt) := 153 | exists ss, Sym.initial stable ss /\ refine_state mi stable ss cs. 154 | 155 | Variable masks : Concrete.Masks. 156 | 157 | Definition all_attacker (xs : seq (Concrete.state mt)) : Prop := 158 | forall x1 x2, In2 x1 x2 xs -> step_a x1 x2 /\ ~ Concrete.step _ masks x1 x2. 159 | 160 | Lemma all_attacker_red ast ast' axs : 161 | all_attacker (ast :: ast' :: axs) -> 162 | all_attacker (ast' :: axs). 163 | Proof. 164 | intros ATTACKER asi asj IN2. 165 | assert (IN2' : In2 asi asj (ast :: ast' :: axs)) 166 | by (simpl; auto). 167 | apply ATTACKER in IN2'. 168 | assumption. 169 | Qed. 170 | 171 | Definition stopping (ss : seq (Concrete.state mt)) : Prop := 172 | (all_attacker ss /\ all in_user ss) 173 | \/ 174 | (exists user monitor, 175 | ss = user ++ monitor /\ 176 | all_attacker user /\ all in_user user /\ 177 | all in_monitor monitor). 178 | 179 | Program Instance concrete_cfi_machine : cfi_machine := { 180 | state := [eqType of Concrete.state mt]; 181 | initial s := cinitial s; 182 | 183 | step s1 s2 := Concrete.step ops masks s1 s2; 184 | step_a := step_a; 185 | 186 | succ := csucc; 187 | stopping := stopping 188 | }. 189 | 190 | End ConcreteSection. 191 | 192 | End Conc. 193 | -------------------------------------------------------------------------------- /ifc/symbolic.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq fintype finfun. 2 | From extructures Require Import ord fmap. 3 | From CoqUtils Require Import hseq word. 4 | From MicroPolicies 5 | Require Import lib.utils common.types symbolic.symbolic symbolic.exec 6 | ifc.labels ifc.common. 7 | 8 | Set Implicit Arguments. 9 | Unset Strict Implicit. 10 | Unset Printing Implicit Defensive. 11 | 12 | Import DoNotation. 13 | 14 | Section Dev. 15 | 16 | Local Open Scope label_scope. 17 | 18 | Variable L : labType. 19 | Variable mt : machine_types. 20 | Variable mops : machine_ops mt. 21 | Context {sregs : syscall_regs mt}. 22 | Context {addrs : ifc_addrs mt}. 23 | 24 | Inductive mem_tag := 25 | | MemInstr 26 | | MemData of L. 27 | 28 | Definition option_of_mem_tag t := 29 | match t with 30 | | MemInstr => None 31 | | MemData l => Some l 32 | end. 33 | 34 | Definition mem_tag_of_option t := 35 | match t with 36 | | None => MemInstr 37 | | Some l => MemData l 38 | end. 39 | 40 | Lemma option_of_mem_tagK : cancel option_of_mem_tag mem_tag_of_option. 41 | Proof. by case. Qed. 42 | 43 | Definition mem_tag_eqMixin := CanEqMixin option_of_mem_tagK. 44 | Canonical mem_tag_eqType := EqType mem_tag mem_tag_eqMixin. 45 | 46 | Import Symbolic. 47 | 48 | Definition ifc_tags := {| 49 | pc_tag_type := [eqType of L]; 50 | reg_tag_type := [eqType of L]; 51 | mem_tag_type := mem_tag_eqType; 52 | entry_tag_type := unit_eqType 53 | |}. 54 | 55 | (** Tag propagation rules. *) 56 | 57 | Definition instr_rules 58 | (op : opcode) (tpc : L) (ts : hseq (tag_type ifc_tags) (inputs op)) : 59 | option (ovec ifc_tags op) := 60 | let ret := fun rtpc (rt : type_of_result ifc_tags (outputs op)) => Some (@OVec ifc_tags op rtpc rt) in 61 | match op, ts, ret with 62 | | NOP, _, ret => ret tpc tt 63 | | CONST, [hseq lold], ret => ret tpc ⊥ 64 | | MOV, [hseq l; lold], ret => ret tpc l 65 | | BINOP b, [hseq l1; l2; lold], ret => ret tpc (l1 ⊔ l2) 66 | | LOAD, [hseq l1; MemData l2; lold], ret => ret tpc (l1 ⊔ l2) 67 | | STORE, [hseq l1; l2; MemData lold], ret => if l1 ⊔ tpc ⊑ lold then 68 | ret tpc (MemData (l1 ⊔ l2 ⊔ tpc)) 69 | else None 70 | | JUMP, [hseq l], ret => ret (l ⊔ tpc) tt 71 | | BNZ, [hseq l], ret => ret (l ⊔ tpc) tt 72 | | JAL, [hseq l1; lold], ret => ret (l1 ⊔ tpc) ⊥ 73 | | _, _, _ => None 74 | end. 75 | 76 | Definition transfer (iv : ivec ifc_tags) : option (vovec ifc_tags (op iv)) := 77 | match iv with 78 | | IVec (OP op) tpc ti ts => 79 | match ti with 80 | | MemInstr => @instr_rules op tpc ts 81 | | MemData _ => None 82 | end 83 | | IVec SERVICE tpc _ _ => Some tt 84 | end. 85 | 86 | (** The internal state for the IFC policy is simply a sequence of atoms that has 87 | been output during execution. *) 88 | 89 | Record int_ifc := IntIFC { 90 | outputs : seq (atom (mword mt) L); 91 | call_stack : seq (call_frame mt L) 92 | }. 93 | 94 | Definition tuple_of_int_ifc x := 95 | (outputs x, call_stack x). 96 | 97 | Definition int_ifc_of_tuple x := 98 | IntIFC x.1 x.2. 99 | 100 | Lemma tuple_of_int_ifcK : cancel tuple_of_int_ifc int_ifc_of_tuple. 101 | Proof. by case. Qed. 102 | 103 | Definition int_ifc_eqMixin := CanEqMixin tuple_of_int_ifcK. 104 | Canonical int_ifc_eqType := Eval hnf in EqType int_ifc int_ifc_eqMixin. 105 | 106 | Global Instance sym_ifc : params := { 107 | ttypes := ifc_tags; 108 | 109 | transfer := transfer; 110 | 111 | internal_state := int_ifc_eqType 112 | }. 113 | 114 | Local Notation state := (@Symbolic.state mt sym_ifc). 115 | 116 | Implicit Types st : state. 117 | 118 | (* Note that we often need to adjust the tag on the caller pc because it may be 119 | lower than the one on the current pc; for example, if we jump to the service 120 | via BNZ instead of JAL. *) 121 | 122 | Definition return_fun st : option state := 123 | if call_stack (internal st) is cf :: stk then 124 | do! retv <- regs st syscall_ret; 125 | do! rs' <- updm (cf_regs cf) syscall_ret (vala retv)@(taga (pc st) ⊔ taga retv); 126 | Some (State (mem st) rs' (cf_pc cf) 127 | {| outputs := outputs (internal st); 128 | call_stack := stk |}) 129 | else None. 130 | 131 | Definition call_fun st : option state := 132 | do! caller_pc <- regs st ra; 133 | let caller_pc := (vala caller_pc)@(taga caller_pc ⊔ taga (pc st)) in 134 | do! called_pc <- regs st syscall_arg1; 135 | Some (State (mem st) (regs st) 136 | (vala called_pc)@(taga called_pc ⊔ taga caller_pc) 137 | {| outputs := outputs (internal st); 138 | call_stack := 139 | CallFrame caller_pc (regs st) 140 | :: call_stack (internal st) 141 | |}). 142 | 143 | Definition output_fun st : option state := 144 | do! raddr <- regs st ra; 145 | let r_pc := taga raddr ⊔ taga (pc st) in 146 | let raddr := (vala raddr)@r_pc in 147 | do! out <- regs st syscall_arg1; 148 | let r_out := taga out in 149 | Some (State (mem st) (regs st) raddr 150 | {| outputs := rcons (outputs (internal st)) 151 | (vala out)@(taga (pc st) ⊔ r_out); 152 | call_stack := call_stack (internal st) 153 | |}). 154 | 155 | Definition ifc_syscalls : syscall_table mt := 156 | [fmap 157 | (return_addr, (Syscall tt return_fun)); 158 | (call_addr, (Syscall tt call_fun)); 159 | (output_addr, (Syscall tt output_fun)) 160 | ]. 161 | 162 | Definition trace n st := 163 | let st' := iter n (fun st' => odflt st' (stepf ifc_syscalls st')) st in 164 | drop (size (outputs (internal st))) (outputs (internal st')). 165 | 166 | Local Notation step := (@Symbolic.step mt mops sym_ifc ifc_syscalls). 167 | Local Notation ratom := (atom (mword mt) (tag_type ifc_tags R)). 168 | Local Notation matom := (atom (mword mt) (tag_type ifc_tags M)). 169 | 170 | Hint Unfold stepf. 171 | Hint Unfold next_state_pc. 172 | Hint Unfold next_state_reg. 173 | Hint Unfold next_state_reg_and_pc. 174 | Hint Unfold next_state. 175 | 176 | Ltac step_event_cat := 177 | simpl in *; repeat autounfold; 178 | intros; subst; simpl in *; 179 | repeat match goal with 180 | | t : (_ * _)%type |- _ => destruct t; simpl in * 181 | end; 182 | match_inv; simpl; exists [::]; rewrite cats0. 183 | 184 | Lemma step_event_cat s s' : 185 | step s s' -> 186 | exists t, outputs (internal s') = outputs (internal s) ++ t. 187 | Proof. 188 | case; try by step_event_cat. 189 | move=> /= m rs pc sc rl [t stk] -> {s} _. 190 | rewrite /ifc_syscalls /run_syscall mkfmapE //=. 191 | case: ifP=> [_ [<-] {sc}|_] /=. 192 | rewrite /return_fun /= => e; match_inv=> /=. 193 | by exists [::]; rewrite cats0. 194 | case: ifP=> [_ [<-] {sc}|_] /=. 195 | rewrite /call_fun /= => e; match_inv=> /=. 196 | by exists [::]; rewrite cats0. 197 | case: ifP=> [_ [<-] {sc}|_] //=. 198 | rewrite /output_fun /= => e; match_inv=> /=. 199 | by rewrite -cats1; eexists; eauto. 200 | Qed. 201 | 202 | End Dev. 203 | -------------------------------------------------------------------------------- /os/os.tex: -------------------------------------------------------------------------------- 1 | \documentclass[svgnames]{beamer} 2 | 3 | \usepackage[utf8]{inputenc} 4 | \usepackage[T1]{fontenc} 5 | \usepackage{tgadventor} 6 | \usepackage{microtype} 7 | 8 | \setbeamertemplate{headline}{} 9 | \setbeamertemplate{navigation symbols}{} 10 | \setbeamertemplate{footline}{} 11 | 12 | \usepackage{tikz} 13 | \usetikzlibrary{calc} 14 | \usetikzlibrary{positioning} 15 | \usetikzlibrary{decorations.pathmorphing, decorations.pathreplacing} 16 | \usetikzlibrary{matrix} 17 | \usetikzlibrary{arrows} 18 | 19 | \definecolor{kernel} {named} {red} 20 | \definecolor{scheduler init} {named} {PaleVioletRed} 21 | \definecolor{yield} {named} {violet} 22 | \definecolor{add 1} {named} {Green} 23 | \definecolor{mul 2} {named} {MediumBlue} 24 | 25 | \tikzset{ every picture/.style = { ultra thick} 26 | , process/.style = {color=white, draw=#1, fill=#1, rounded corners} 27 | , can jump to/.style = {color=#1, ->} 28 | , can store to/.style = {color=#1, decorate, decoration={snake, pre length = 1mm, post length=1mm}, ->} 29 | , needs jump access/.style = {can jump to=#1, dashed} 30 | , needs store access/.style = {can store to=#1, dashed} } 31 | 32 | \begin{document} 33 | \begin{frame} 34 | \begin{center} 35 | \begin{tikzpicture}[node distance=2cm] 36 | \node (kernel) [process = kernel] {Compartmentalization kernel} ; 37 | \node (scheduler init) [process = scheduler init, below = of kernel] {Scheduler initialization} ; 38 | \node (yield) [process = yield, below = of scheduler init] {Yield} ; 39 | \node (add 1) [process = add 1, below left = 2cm and 2cm of yield] {$+1$ process} ; 40 | \node (mul 2) [process = mul 2, below right = 2cm and 2cm of yield] {$\times 2$ process} ; 41 | 42 | \path[shorten < = -1mm] 43 | (kernel) edge[can jump to = kernel] 44 | node[left] 45 | {Jump to start} 46 | (scheduler init) 47 | (kernel.east) edge[needs jump access = kernel, shorten < = 0cm, to path = {-- ++(1.5cm,0) |- (\tikztotarget) \tikztonodes}] 48 | node[above left = 3.3cm and 0cm, align = right, text width = 3.1cm] 49 | {Needs jump \mbox{access} to set up compartments} 50 | (yield.east) 51 | (scheduler init) edge[can store to = scheduler init] 52 | node[right, text width=3.4cm] 53 | {Store to yield's saved PID and process addresses} 54 | (yield) 55 | (scheduler init) edge[can jump to = scheduler init, transform canvas={xshift=-.7cm}] 56 | node[left] 57 | {Jump to start} 58 | (add 1) 59 | (yield) edge[can jump to = yield, shorten < = -.25cm, transform canvas={xshift=-.35cm}] 60 | node[above,sloped] 61 | {Jump anywhere} 62 | (add 1) 63 | (yield) edge[can jump to = yield, shorten < = -.25cm, transform canvas={xshift=+.35cm}] 64 | node[above,sloped] 65 | {Jump anywhere} 66 | (mul 2) 67 | (add 1) edge[can jump to = add 1] 68 | node[below,sloped] 69 | {Jump to start} 70 | (yield) 71 | (mul 2) edge[can jump to = mul 2] 72 | node[below,sloped] 73 | {Jump to start} 74 | (yield) 75 | (mul 2) edge[can store to = mul 2] 76 | node[below] 77 | {Store to shared address} 78 | (add 1) ; 79 | \end{tikzpicture} 80 | \end{center} 81 | \end{frame} 82 | 83 | \begin{frame} 84 | \begin{center} 85 | \footnotesize 86 | \begin{tikzpicture} 87 | \newlength\MemRegionHeight 88 | \setlength\MemRegionHeight{.9cm} 89 | \matrix[ matrix of nodes, every node/.style={draw=black}, color=white 90 | , row sep=-1.6pt, minimum width=8cm, minimum height=\MemRegionHeight 91 | , one address/.style={minimum height=\MemRegionHeight/2} ] 92 | { 93 | |[fill=kernel] (kernel code)| Compartmentalization kernel code \\ 94 | |[fill=kernel] (kernel data)| Compartmentalization kernel service arguments \\ 95 | % 96 | |[fill=scheduler init] (init code)| Scheduler initialization code \\ 97 | % 98 | |[fill=yield] (yield code)| Yield code \\ 99 | |[fill=yield, one address] (yield pid)| Scheduled PID \\ 100 | |[fill=yield, one address] (yield proc 1 pc)| Process 1's stored pc \\ 101 | |[fill=yield] (yield proc 1 regs)| Process 1's stored registers \\ 102 | |[fill=yield, one address] (yield proc 2 pc)| Process 2's stored pc \\ 103 | |[fill=yield] (yield proc 2 regs)| Process 2's stored registers \\ 104 | % 105 | |[fill=add 1] (add 1 code)| $+1$ process code \\ 106 | |[fill=add 1, one address] (shared data)| Shared user data \\ 107 | % 108 | |[fill=mul 2] (mul 2 code)| $\times2$ process code \\ 109 | } ; 110 | 111 | \foreach \mems/\color in { {kernel code}/kernel% 112 | , {yield code, yield pid, yield proc 1 pc, yield proc 1 regs, yield proc 2 pc}/yield% 113 | , {add 1 code}/add 1} 114 | { 115 | \foreach \mem in \mems { 116 | \message{\mem} 117 | \draw[draw=\color, dashed, line width=3.2pt, shorten < = 3pt, shorten > = 3pt] 118 | ($(\mem.south west)+(0,.8pt)$) -- ($(\mem.south east)+(0,.8pt)$) ; 119 | } 120 | } 121 | 122 | \useasboundingbox (current bounding box.north west) rectangle (current bounding box.south east) ; 123 | 124 | \draw[color=add 1, decorate, decoration={brace, amplitude=.15cm}] 125 | ($(shared data.south west)+(-.1cm,3.2pt)$) -- ($(add 1 code.north west)+(-.1cm,-3.2pt)$) 126 | coordinate[midway, xshift=-.25cm] (add 1 all) ; 127 | \draw[color=mul 2, decorate, decoration={brace, amplitude=.15cm}] 128 | ($(mul 2 code.south west)+(-.1cm,3.2pt)$) -- ($(mul 2 code.north west)+(-.1cm,-3.2pt)$) 129 | coordinate[midway, xshift=-.25cm] (mul 2 all) ; 130 | 131 | \path[can store to/.style={color=########1, -latex}] 132 | (kernel code.west) edge[can jump to=kernel, out=180, in=180] ($(init code.north west)+(0,-2.4pt)$) 133 | edge[can jump to=kernel, dashed, out=180, in=180] ($(yield code.north west)+(0,-2.4pt)$) 134 | (init code.west) edge[can jump to=scheduler init, out=180, in=180] ($(add 1 code.north west)+(0,-2.4pt)$) 135 | edge[can store to=scheduler init, out=180, in=180] (yield pid.west) 136 | edge[can store to=scheduler init, out=180, in=180] (yield proc 1 pc.west) 137 | edge[can store to=scheduler init, out=180, in=180] (yield proc 2 pc.west) 138 | (yield code.west) edge[can jump to=yield, out=180, in=180] (add 1 all) 139 | edge[can jump to=yield, out=180, in=180] (mul 2 all) 140 | (mul 2 code.east) edge[can jump to=mul 2, out=0, in=+30] ($(yield code.north east)+(0,-3.0pt)$) 141 | (add 1 code.east) edge[can jump to=add 1, out=0, in=-30] ($(yield code.north east)+(0,-6.0pt)$) 142 | (mul 2 code.east) edge[can store to=mul 2, out=0, in=0, looseness=3] (shared data.east) 143 | ; 144 | \end{tikzpicture} 145 | \end{center} 146 | \end{frame} 147 | \end{document} 148 | -------------------------------------------------------------------------------- /os/haskell/Haskell/Monad/Assembler/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, 2 | FlexibleInstances, UndecidableInstances #-} 3 | 4 | {-| 5 | Module : Haskell.Monad.Assembler.Class 6 | Description : Monad class for assembling a Von Neumann-architecture machine 7 | Copyright : © 2015 Antal Spector-Zabusky 8 | License : BSD3 9 | Maintainer : Antal Spector-Zabusky 10 | Stability : experimental 11 | Portability : GHC only 12 | 13 | This module provides a 'MonadAssembler' monad class which models monads that 14 | support generating the memory of a Von Neumann-architecture machine. The 15 | intended model of this class is the 'AssemblerT' monad transformer from 16 | "Haskell.Monad.Trans.Assembler"; for more information and documentation, see 17 | that module. 18 | -} 19 | 20 | module Haskell.Monad.Assembler.Class (MonadAssembler(..)) where 21 | 22 | import Control.Applicative 23 | import Control.Monad.Fix 24 | 25 | import qualified Haskell.Monad.Trans.Assembler as A 26 | 27 | import Control.Monad.Trans 28 | import Control.Monad.Trans.Identity 29 | import Control.Monad.Trans.Reader 30 | import qualified Control.Monad.Trans.Writer.Lazy as WL 31 | import qualified Control.Monad.Trans.Writer.Strict as WS 32 | import qualified Control.Monad.Trans.State.Lazy as SL 33 | import qualified Control.Monad.Trans.State.Strict as SS 34 | import qualified Control.Monad.Trans.RWS.Lazy as RWSL 35 | import qualified Control.Monad.Trans.RWS.Strict as RWSS 36 | import Control.Monad.Trans.Maybe 37 | import Control.Monad.Trans.Except 38 | import Control.Monad.Trans.Either 39 | import Control.Monad.Trans.Error 40 | import Data.Monoid 41 | 42 | class (Functor m, Applicative m, MonadFix m, Integral p, Ord p, Num w) => 43 | MonadAssembler e p w m 44 | | m -> e p w where 45 | -- The 'Functor' and 'Applicative' constraints are there in anticipation of 46 | -- the AMP. Should I leave the other non-'MonadFix' constraints on the class? 47 | -- I'm unsure... 48 | asmWords :: [w] -> m () 49 | asmWord :: w -> m () 50 | asmWord w = asmWords [w] 51 | 52 | reserve :: p -> m p 53 | 54 | here :: m p 55 | reservedSegment :: m p 56 | 57 | asmError :: e -> m a 58 | asmDelayedError :: Maybe e -> m () 59 | 60 | program :: m a -> m a 61 | 62 | instance (MonadFix m, Integral p, Ord p, Num w) => MonadAssembler e p w (A.AssemblerT e p w m) where 63 | asmWords = A.asmWords 64 | asmWord = A.asmWord 65 | 66 | reserve = A.reserve 67 | 68 | here = A.here 69 | reservedSegment = A.reservedSegment 70 | 71 | asmError = A.asmError 72 | asmDelayedError = A.asmDelayedError 73 | 74 | program = A.program 75 | 76 | instance MonadAssembler e p w m => MonadAssembler e p w (IdentityT m) where 77 | asmWords = lift . asmWords 78 | asmWord = lift . asmWord 79 | 80 | reserve = lift . reserve 81 | 82 | here = lift here 83 | reservedSegment = lift reservedSegment 84 | 85 | asmError = lift . asmError 86 | asmDelayedError = lift . asmDelayedError 87 | 88 | program = mapIdentityT program 89 | 90 | instance MonadAssembler e p w m => MonadAssembler e p w (ReaderT r m) where 91 | asmWords = lift . asmWords 92 | asmWord = lift . asmWord 93 | 94 | reserve = lift . reserve 95 | 96 | here = lift here 97 | reservedSegment = lift reservedSegment 98 | 99 | asmError = lift . asmError 100 | asmDelayedError = lift . asmDelayedError 101 | 102 | program = mapReaderT program 103 | 104 | instance (Monoid v, MonadAssembler e p w m) => MonadAssembler e p w (WL.WriterT v m) where 105 | asmWords = lift . asmWords 106 | asmWord = lift . asmWord 107 | 108 | reserve = lift . reserve 109 | 110 | here = lift here 111 | reservedSegment = lift reservedSegment 112 | 113 | asmError = lift . asmError 114 | asmDelayedError = lift . asmDelayedError 115 | 116 | program = WL.mapWriterT program 117 | 118 | instance (Monoid v, MonadAssembler e p w m) => MonadAssembler e p w (WS.WriterT v m) where 119 | asmWords = lift . asmWords 120 | asmWord = lift . asmWord 121 | 122 | reserve = lift . reserve 123 | 124 | here = lift here 125 | reservedSegment = lift reservedSegment 126 | 127 | asmError = lift . asmError 128 | asmDelayedError = lift . asmDelayedError 129 | 130 | program = WS.mapWriterT program 131 | 132 | instance MonadAssembler e p w m => MonadAssembler e p w (SL.StateT s m) where 133 | asmWords = lift . asmWords 134 | asmWord = lift . asmWord 135 | 136 | reserve = lift . reserve 137 | 138 | here = lift here 139 | reservedSegment = lift reservedSegment 140 | 141 | asmError = lift . asmError 142 | asmDelayedError = lift . asmDelayedError 143 | 144 | program = SL.mapStateT program 145 | 146 | instance MonadAssembler e p w m => MonadAssembler e p w (SS.StateT s m) where 147 | asmWords = lift . asmWords 148 | asmWord = lift . asmWord 149 | 150 | reserve = lift . reserve 151 | 152 | here = lift here 153 | reservedSegment = lift reservedSegment 154 | 155 | asmError = lift . asmError 156 | asmDelayedError = lift . asmDelayedError 157 | 158 | program = SS.mapStateT program 159 | 160 | instance (Monoid v, MonadAssembler e p w m) => MonadAssembler e p w (RWSL.RWST r v s m) where 161 | asmWords = lift . asmWords 162 | asmWord = lift . asmWord 163 | 164 | reserve = lift . reserve 165 | 166 | here = lift here 167 | reservedSegment = lift reservedSegment 168 | 169 | asmError = lift . asmError 170 | asmDelayedError = lift . asmDelayedError 171 | 172 | program = RWSL.mapRWST program 173 | 174 | instance (Monoid v, MonadAssembler e p w m) => MonadAssembler e p w (RWSS.RWST r v s m) where 175 | asmWords = lift . asmWords 176 | asmWord = lift . asmWord 177 | 178 | reserve = lift . reserve 179 | 180 | here = lift here 181 | reservedSegment = lift reservedSegment 182 | 183 | asmError = lift . asmError 184 | asmDelayedError = lift . asmDelayedError 185 | 186 | program = RWSS.mapRWST program 187 | 188 | instance MonadAssembler e p w m => MonadAssembler e p w (MaybeT m) where 189 | asmWords = lift . asmWords 190 | asmWord = lift . asmWord 191 | 192 | reserve = lift . reserve 193 | 194 | here = lift here 195 | reservedSegment = lift reservedSegment 196 | 197 | asmError = lift . asmError 198 | asmDelayedError = lift . asmDelayedError 199 | 200 | program = mapMaybeT program 201 | 202 | instance MonadAssembler e p w m => MonadAssembler e p w (ExceptT x m) where 203 | asmWords = lift . asmWords 204 | asmWord = lift . asmWord 205 | 206 | reserve = lift . reserve 207 | 208 | here = lift here 209 | reservedSegment = lift reservedSegment 210 | 211 | asmError = lift . asmError 212 | asmDelayedError = lift . asmDelayedError 213 | 214 | program = mapExceptT program 215 | 216 | instance MonadAssembler e p w m => MonadAssembler e p w (EitherT x m) where 217 | asmWords = lift . asmWords 218 | asmWord = lift . asmWord 219 | 220 | reserve = lift . reserve 221 | 222 | here = lift here 223 | reservedSegment = lift reservedSegment 224 | 225 | asmError = lift . asmError 226 | asmDelayedError = lift . asmDelayedError 227 | 228 | program = mapEitherT program 229 | 230 | instance (Error x, MonadAssembler e p w m) => MonadAssembler e p w (ErrorT x m) where 231 | asmWords = lift . asmWords 232 | asmWord = lift . asmWord 233 | 234 | reserve = lift . reserve 235 | 236 | here = lift here 237 | reservedSegment = lift reservedSegment 238 | 239 | asmError = lift . asmError 240 | asmDelayedError = lift . asmDelayedError 241 | 242 | program = mapErrorT program 243 | -------------------------------------------------------------------------------- /symbolic/int_32.v: -------------------------------------------------------------------------------- 1 | (* Specializing protected monitor for symbolic machine to 32 bits *) 2 | 3 | From mathcomp Require Import ssrnat eqtype seq ssrint. 4 | From extructures Require Import ord fmap. 5 | From CoqUtils Require Import word. 6 | 7 | Require Import lib.utils. 8 | Require Import common.types common.segment. 9 | Require Import concrete.int_32. 10 | Require Import concrete.concrete. 11 | Require Import symbolic.rules. 12 | Require Import symbolic.fault_handler. 13 | Require Import symbolic.symbolic. 14 | 15 | Import DoNotation. 16 | Import Concrete. 17 | 18 | Set Implicit Arguments. 19 | Unset Strict Implicit. 20 | Unset Printing Implicit Defensive. 21 | 22 | Section WithClasses. 23 | 24 | Let mt := concrete_int_32_mt. 25 | 26 | Instance concrete_int_32_fh : fault_handler_params mt := { 27 | rop := as_word 1; 28 | rtpc := as_word 2; 29 | rti := as_word 3; rt1 := as_word 4; rt2 := as_word 5; 30 | rt3 := as_word 6; 31 | rb := as_word 7; 32 | ri1 := as_word 8; ri2 := as_word 9; ri3 := as_word 10; 33 | ri4 := as_word 11; ri5 := as_word 12; 34 | rtrpc := as_word 13; rtr := as_word 14; 35 | raddr := as_word 15; 36 | 37 | (* WARNING: This doesn't quite work in the general case, because imm 38 | should be strictly smaller than word. However, it should work 39 | fine when used on small immediates *) 40 | load_const := fun (x : mword mt) (r : reg mt) => 41 | [:: Const (swcast x) r] 42 | }. 43 | 44 | Fixpoint insert_from {A : Type} (i : word 32) (l : seq A) 45 | (mem : {fmap word 32 -> A}) : {fmap word 32 -> A} := 46 | match l with 47 | | [::] => mem 48 | | h :: l' => insert_from (i + 1)%w l' (setm mem i h) 49 | end. 50 | 51 | Fixpoint constants_from {A : Type} (i : word 32) (n : nat) (x : A) 52 | (mem : {fmap word 32 -> A}) : {fmap word 32 -> A} := 53 | match n with 54 | | O => mem 55 | | S n' => constants_from (i + 1)%w n' x (setm mem i x) 56 | end. 57 | 58 | Definition w := mword mt. 59 | 60 | Definition monitorize (seg : @relocatable_segment mt w w) 61 | : @relocatable_segment mt w (atom (word 32) (word 32)) := 62 | let (l,gen) := seg in 63 | (l, fun b rest => map (fun x => Atom x (Concrete.TMonitor : w)) (gen b rest)). 64 | 65 | (* FIXME: right now, this definition works only for the sealing 66 | machine, whose system calls have trivial entry tags. Ideally, the 67 | system call should provide monitorize_syscall with a tag for its entry 68 | point. *) 69 | Definition monitorize_syscall (seg : @relocatable_segment mt w w) 70 | : relocatable_segment w (atom w w) := 71 | let (l,gen) := seg in 72 | ((l + 1)%nat, fun b rest => 73 | (* ENTRY tag with constant ut *) 74 | (encode_instr (Nop _))@(as_word 2) :: 75 | map (fun x => x@Concrete.TMonitor) (gen b rest)). 76 | 77 | Definition monitorize_user_tag t : word 32 := 78 | (shlw t (as_word 2) + 1)%w. 79 | 80 | Definition monitorize_tags 81 | {X : Type} 82 | (seg : @relocatable_segment mt X (atom w w)) 83 | : relocatable_segment X (atom w w) := 84 | let (l,gen) := seg in 85 | (* BCP: This has to correspond with the tag encoding used in 86 | fault_handler.v -- probably better to write it there rather than here *) 87 | (l, 88 | fun b rest => 89 | map (fun x => Atom (vala x) 90 | (monitorize_user_tag (taga x))) (gen b rest)). 91 | 92 | (* Build the basic monitor memory on top of which we will put user 93 | programs. Returns a triple with the monitor memory, the base user 94 | address, and a list of system call addresses. *) 95 | Definition build_monitor_memory 96 | (extra_state : relocatable_segment _ w) 97 | (handler : relocatable_segment w w) 98 | (syscalls : seq (relocatable_segment w w)) 99 | : Concrete.memory mt * w * seq w := 100 | let cacheCell := Atom 0%w (Concrete.TMonitor : w) in 101 | let '((monitor_length,gen_monitor), offsets) := 102 | concat_and_measure_relocatable_segments 103 | ([:: monitorize handler; 104 | monitorize extra_state] ++ 105 | (map monitorize_syscall syscalls)) in 106 | match offsets with 107 | | _ :: extra_state_offset :: syscall_offsets => 108 | let base_addr := fault_handler_start _ in 109 | let extra_state_addr := (base_addr + as_word extra_state_offset)%w in 110 | let user_code_addr := (base_addr + as_word monitor_length)%w in 111 | let syscall_addrs := 112 | map (fun off : nat => base_addr + as_word off)%w 113 | syscall_offsets in 114 | let monitor := gen_monitor base_addr extra_state_addr in 115 | let mem := 116 | ( constants_from 0%w 8 cacheCell 117 | ∘ insert_from base_addr monitor ) 118 | emptym in 119 | (mem, user_code_addr, syscall_addrs) 120 | | _ => 121 | (* Should not happen *) 122 | (emptym, as_word 0, [::]) 123 | end. 124 | 125 | (* BCP: Register initialization may need to be generalized at some 126 | point. Right now, it initializes all user registers with the 127 | tag (USER 0). But the user program might conceivably want to start 128 | with a different tag assignment. (On the other hand, maybe 129 | policies can always simply be written so that tag 0 is a reasonable 130 | default.) *) 131 | 132 | Program Definition concrete_initial_state 133 | {Addrs} 134 | (initial_memory : Concrete.memory mt) 135 | (user_mem_addr : w) 136 | (syscall_addrs : Addrs) 137 | (user_mem : relocatable_segment Addrs (atom w w)) 138 | (initial_pc_tag : w) 139 | (user_regs : seq (reg mt)) 140 | (initial_reg_tag : w) 141 | : Concrete.state mt := 142 | let '(_, user_gen) := monitorize_tags user_mem in 143 | let mem' := insert_from user_mem_addr (user_gen user_mem_addr syscall_addrs) initial_memory in 144 | let kregs := 145 | foldl 146 | (fun regs r => 147 | setm regs r zerow@(Concrete.TMonitor:w)) 148 | emptym (monitor_regs concrete_int_32_fh) in 149 | let regs := 150 | foldl 151 | (fun regs r => 152 | setm regs r zerow@(monitorize_user_tag initial_reg_tag)) 153 | kregs user_regs in 154 | {| 155 | Concrete.mem := mem'; 156 | Concrete.regs := regs; 157 | Concrete.cache := ground_rules _; 158 | Concrete.pc := user_mem_addr@(monitorize_user_tag initial_pc_tag); 159 | Concrete.epc := zerow@zerow 160 | |}. 161 | 162 | (* TODO: Regularize naming of base addresses and system call stuff. *) 163 | 164 | Context {sp: Symbolic.params}. 165 | 166 | Let sym_atom k := atom (mword mt) (Symbolic.tag_type (@Symbolic.ttypes sp) k). 167 | 168 | Program Definition symbolic_initial_state 169 | {Addrs} 170 | (user_mem : relocatable_segment Addrs (sym_atom Symbolic.M)) 171 | (base_addr : sym_atom Symbolic.P) (syscall_addrs : Addrs) 172 | (user_regs : seq (reg mt)) 173 | (initial_reg_value : sym_atom Symbolic.R) 174 | (initial_internal_state : Symbolic.internal_state) 175 | : @Symbolic.state mt sp := 176 | let (_, gen) := user_mem in 177 | let mem_contents := gen (vala base_addr) syscall_addrs in 178 | let mem := 179 | snd (foldl 180 | (fun x c => let: (i,m) := x in 181 | (i + 1, setm m i c)%w) 182 | ((vala base_addr), emptym) mem_contents) in 183 | let regs := 184 | foldl 185 | (fun regs r => setm regs r initial_reg_value) 186 | emptym user_regs in 187 | {| 188 | Symbolic.mem := mem; 189 | Symbolic.regs := regs; 190 | Symbolic.pc := base_addr; 191 | Symbolic.internal := initial_internal_state 192 | |}. 193 | 194 | (* BCP/MD: These should all be distinct from monitor registers in 195 | symbolic.int_32, though this should not cause axiom failures -- 196 | just puzzling user program errors! *) 197 | 198 | Global Instance concrete_int_32_scr : syscall_regs mt := {| 199 | syscall_ret := as_word 16; 200 | syscall_arg1 := as_word 17; 201 | syscall_arg2 := as_word 18; 202 | syscall_arg3 := as_word 19 203 | |}. 204 | 205 | End WithClasses. 206 | -------------------------------------------------------------------------------- /symbolic/exec.v: -------------------------------------------------------------------------------- 1 | From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq. 2 | From extructures Require Import ord fmap. 3 | From CoqUtils Require Import hseq word. 4 | Require Import lib.utils common.types symbolic.symbolic. 5 | 6 | Set Implicit Arguments. 7 | Unset Strict Implicit. 8 | Unset Printing Implicit Defensive. 9 | 10 | Import DoNotation. 11 | 12 | Section WithClasses. 13 | 14 | Context {mt : machine_types} 15 | {ops : machine_ops mt} 16 | {sp : Symbolic.params}. 17 | 18 | Variable table : Symbolic.syscall_table mt. 19 | 20 | Import Symbolic. 21 | 22 | Local Open Scope word_scope. 23 | Local Notation "x .+1" := (x + 1). 24 | 25 | Definition stepf (st : state mt) : option (state mt) := 26 | let 'State mem reg pc@tpc extra := st in 27 | match mem pc with 28 | | Some iti => 29 | let: i@ti := iti in 30 | do! instr <- decode_instr i; 31 | match instr with 32 | | Nop => 33 | let mvec := IVec NOP tpc ti [hseq] in 34 | next_state_pc st mvec (pc.+1) 35 | | Const n r => 36 | do! old <- reg r; 37 | let: _@told := old in 38 | let ivec := IVec CONST tpc ti [hseq told] in 39 | next_state_reg st ivec r (swcast n) 40 | | Mov r1 r2 => 41 | do! a1 <- reg r1; 42 | let: w1@t1 := a1 in 43 | do! a2 <- reg r2; 44 | let: _@told := a2 in 45 | let mvec := IVec MOV tpc ti [hseq t1;told] in 46 | next_state_reg st mvec r2 w1 47 | | Binop op r1 r2 r3 => 48 | do! a1 <- reg r1; 49 | let: w1@t1 := a1 in 50 | do! a2 <- reg r2; 51 | let: w2@t2 := a2 in 52 | do! a3 <- reg r3; 53 | let: _@told := a3 in 54 | let mvec := IVec (BINOP op) tpc ti [hseq t1;t2;told] in 55 | next_state_reg st mvec r3 (binop_denote op w1 w2) 56 | | Load r1 r2 => 57 | do! a1 <- reg r1; 58 | let: w1@t1 := a1 in 59 | do! amem <- mem w1; 60 | let: w2@t2 := amem in 61 | do! a2 <- reg r2; 62 | let: _@told := a2 in 63 | let mvec := IVec LOAD tpc ti [hseq t1;t2;told] in 64 | next_state_reg st mvec r2 w2 65 | | Store r1 r2 => 66 | do! a1 <- reg r1; 67 | let: w1@t1 := a1 in 68 | do! amem <- mem w1; 69 | let: _@told := amem in 70 | do! a2 <- reg r2; 71 | let: w2@t2 := a2 in 72 | let mvec := IVec STORE tpc ti [hseq t1;t2;told] in 73 | @next_state _ _ st mvec (fun ov => 74 | do! mem' <- updm mem w1 w2@(tr ov); 75 | Some (State mem' reg (pc.+1)@(trpc ov) extra)) 76 | | Jump r => 77 | do! a <- reg r; 78 | let: w@t1 := a in 79 | let mvec := IVec JUMP tpc ti [hseq t1] in 80 | next_state_pc st mvec w 81 | | Bnz r n => 82 | do! a <- reg r; 83 | let: w@t1 := a in 84 | let pc' := pc + (if w == 0 85 | then 1 else swcast n) in 86 | let ivec := IVec BNZ tpc ti [hseq t1] in 87 | next_state_pc st ivec pc' 88 | | Jal r => 89 | do! a <- reg r; 90 | let: w@t1 := a in 91 | do! oldtold <- reg ra; 92 | let: _@told := oldtold in 93 | let mvec := IVec JAL tpc ti [hseq t1; told] in 94 | next_state_reg_and_pc st mvec ra (pc.+1) w 95 | | JumpEpc | AddRule | GetTag _ _ | PutTag _ _ _ | Halt => 96 | None 97 | end 98 | | None => 99 | match mem pc with 100 | | None => 101 | do! sc <- table pc; 102 | run_syscall sc st 103 | | Some _ => 104 | None 105 | end 106 | end. 107 | 108 | Lemma stepP : 109 | forall st st', 110 | stepf st = Some st' <-> 111 | step table st st'. 112 | Proof. 113 | intros st st'. split; intros STEP. 114 | { destruct st as [mem reg [pc tpc] int]. 115 | move: STEP => /=; case GET: (mem pc) => [[i ti]|] //= STEP; 116 | apply obind_inv in STEP. 117 | - destruct STEP as (instr & INSTR & STEP). 118 | destruct instr; try discriminate; 119 | repeat match goal with 120 | | STEP : (do! x <- ?t; _) = Some _ |- _ => 121 | destruct t eqn:?; simpl in STEP; try discriminate 122 | | x : atom _ _ |- _ => 123 | destruct x; simpl in * 124 | | rv : ovec _ |- _ => 125 | destruct rv; simpl in * 126 | | H : Some _ = Some _ |- _ => 127 | inversion H; subst; clear H 128 | end; 129 | s_econstructor (solve [eauto]). 130 | 131 | - destruct STEP as (sc & GETCALL & STEP). 132 | s_econstructor (solve [eauto]). 133 | } 134 | { unfold stepf. 135 | inversion STEP; subst; rewrite PC; try (subst mv); 136 | simpl; 137 | repeat match goal with 138 | | [H: ?Expr = _ |- context[?Expr]] => 139 | rewrite H; simpl 140 | end; by reflexivity. 141 | } 142 | Qed. 143 | 144 | Lemma stepP' : 145 | forall st st', 146 | reflect (step table st st') (stepf st == Some st'). 147 | Proof. 148 | move => st st'. 149 | apply (iffP eqP); by move => /stepP. 150 | Qed. 151 | 152 | Definition build_ivec st : option (ivec ttypes) := 153 | match mem st (pcv st) with 154 | | Some i => 155 | match decode_instr (vala i) with 156 | | Some op => 157 | let part := @IVec ttypes (opcode_of op) (pct st) (taga i) in 158 | match op return (hseq (tag_type ttypes) (inputs (opcode_of op)) -> 159 | ivec ttypes) -> option (ivec ttypes) with 160 | | Nop => fun part => Some (part [hseq]) 161 | | Const n r => fun part => 162 | do! old <- regs st r; 163 | Some (part [hseq taga old]) 164 | | Mov r1 r2 => fun part => 165 | do! v1 <- regs st r1; 166 | do! v2 <- regs st r2; 167 | Some (part [hseq (taga v1); (taga v2)]) 168 | | Binop _ r1 r2 r3 => fun part => 169 | do! v1 <- regs st r1; 170 | do! v2 <- regs st r2; 171 | do! v3 <- regs st r3; 172 | Some (part [hseq (taga v1); (taga v2); (taga v3)]) 173 | | Load r1 r2 => fun part => 174 | do! w1 <- regs st r1; 175 | do! w2 <- (mem st) (vala w1); 176 | do! old <- regs st r2; 177 | Some (part [hseq (taga w1); (taga w2); (taga old)]) 178 | | Store r1 r2 => fun part => 179 | do! w1 <- regs st r1; 180 | do! w2 <- regs st r2; 181 | do! w3 <- mem st (vala w1); 182 | Some (part [hseq (taga w1); (taga w2); (taga w3)]) 183 | | Jump r => fun part => 184 | do! w <- regs st r; 185 | Some (part [hseq taga w]) 186 | | Bnz r n => fun part => 187 | do! w <- regs st r; 188 | Some (part [hseq taga w]) 189 | | Jal r => fun part => 190 | do! w <- regs st r; 191 | do! old <- regs st ra; 192 | Some (part [hseq taga w; taga old]) 193 | | JumpEpc => fun _ => None 194 | | AddRule => fun _ => None 195 | | GetTag _ _ => fun _ => None 196 | | PutTag _ _ _ => fun _ => None 197 | | Halt => fun _ => None 198 | end part 199 | | None => None 200 | end 201 | | None => 202 | match table (pcv st) with 203 | | Some sc => 204 | Some (IVec SERVICE (pct st) (entry_tag sc) [hseq]) 205 | | None => None 206 | end 207 | end. 208 | 209 | Lemma step_build_ivec st st' : 210 | step table st st' -> 211 | exists ivec ovec, 212 | build_ivec st = Some ivec /\ 213 | transfer ivec = Some ovec. 214 | Proof. 215 | move/stepP. 216 | rewrite {1}(state_eta st) /= /build_ivec. 217 | case: (getm _ _) => [[i ti]|] //=; last first. 218 | case: (getm _ _) => [sc|] //=. 219 | rewrite /run_syscall /=. 220 | case TRANS: (transfer _) => [ovec|] //= _. 221 | by eauto. 222 | case: (decode_instr i) => [instr|] //=. 223 | rewrite /next_state_pc /next_state_reg /next_state_reg_and_pc /next_state. 224 | by destruct instr; move=> STEP; match_inv; first [ eauto | discriminate ]. 225 | Qed. 226 | 227 | End WithClasses. 228 | --------------------------------------------------------------------------------