-
Notifications
You must be signed in to change notification settings - Fork 63
/
Builtins.hs
1917 lines (1715 loc) · 73.9 KB
/
Builtins.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{- |
Module : SAWScript.Crucible.LLVM.Builtins
Description : Implementations of Crucible-related SAW-Script primitives.
License : BSD3
Maintainer : atomb
Stability : provisional
-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses#-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module SAWScript.Crucible.LLVM.Builtins
( show_cfg
, crucible_execute_func
, crucible_return
, crucible_precond
, crucible_postcond
, crucible_llvm_cfg
, crucible_llvm_extract
, crucible_llvm_compositional_extract
, crucible_llvm_verify
, crucible_llvm_array_size_profile
, crucible_setup_val_to_typed_term
, crucible_spec_size
, crucible_spec_solvers
, crucible_ghost_value
, crucible_declare_ghost_state
, crucible_equal
, crucible_points_to
, crucible_conditional_points_to
, crucible_fresh_pointer
, crucible_llvm_unsafe_assume_spec
, crucible_fresh_var
, crucible_alloc
, crucible_alloc_aligned
, crucible_alloc_readonly
, crucible_alloc_readonly_aligned
, crucible_alloc_with_size
, crucible_alloc_global
, crucible_fresh_expanded_val
--
-- These function are common to LLVM & JVM implementation (not for external use)
, setupArg
, setupArgs
, getGlobalPair
, runCFG
, displayVerifExceptionOpts
, findDecl
, findDefMaybeStatic
, setupLLVMCrucibleContext
) where
import Prelude hiding (fail)
import qualified Control.Exception as X
import Control.Lens
import Control.Monad.State hiding (fail)
import Control.Monad.Fail (MonadFail(..))
import qualified Data.Bimap as Bimap
import Data.Char (isDigit)
import Data.Foldable (for_, toList, fold)
import Data.Function
import Data.IORef
import Data.List
import Data.List.Extra (nubOrd)
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.String
import Data.Map (Map)
import qualified Data.Map as Map
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Set as Set
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Vector as V
import System.IO
import qualified Text.LLVM.AST as L
import qualified Text.LLVM.PP as L (ppType, ppSymbol)
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>))
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import qualified Control.Monad.Trans.Maybe as MaybeT
-- parameterized-utils
import Data.Parameterized.Classes
import Data.Parameterized.NatRepr
import Data.Parameterized.Nonce
import Data.Parameterized.Some
-- cryptol
import qualified Cryptol.TypeCheck.Type as Cryptol
-- what4
import qualified What4.Concrete as W4
import qualified What4.Config as W4
import qualified What4.FunctionName as W4
import qualified What4.LabeledPred as W4
import qualified What4.ProgramLoc as W4
import qualified What4.Interface as W4
import qualified What4.Expr.Builder as W4
-- crucible
import qualified Lang.Crucible.Backend as Crucible
import qualified Lang.Crucible.Backend.SAWCore as CrucibleSAW
import qualified Lang.Crucible.CFG.Core as Crucible
import qualified Lang.Crucible.CFG.Extension as Crucible
(IsSyntaxExtension)
import qualified Lang.Crucible.FunctionHandle as Crucible
import qualified Lang.Crucible.Simulator as Crucible
import qualified Lang.Crucible.Simulator.Breakpoint as Crucible
import qualified Lang.Crucible.Simulator.GlobalState as Crucible
import qualified Lang.Crucible.Simulator.PathSatisfiability as Crucible
-- crucible-llvm
import qualified Lang.Crucible.LLVM.ArraySizeProfile as Crucible
import qualified Lang.Crucible.LLVM.DataLayout as Crucible
import Lang.Crucible.LLVM.Extension (LLVM)
import qualified Lang.Crucible.LLVM.Bytes as Crucible
import qualified Lang.Crucible.LLVM.MemModel as Crucible
import qualified Lang.Crucible.LLVM.Translation as Crucible
import qualified SAWScript.Crucible.LLVM.CrucibleLLVM as Crucible
-- parameterized-utils
import qualified Data.Parameterized.TraversableFC as Ctx
import qualified Data.Parameterized.Context as Ctx
-- saw-core
import Verifier.SAW.FiniteValue (ppFirstOrderValue)
import Verifier.SAW.SharedTerm
import Verifier.SAW.TypedAST
import Verifier.SAW.Recognizer
import Verifier.SAW.TypedTerm
-- saw-script
import SAWScript.AST (Located(..))
import SAWScript.Proof
import SAWScript.Prover.SolverStats
import SAWScript.Prover.Versions
import SAWScript.TopLevel
import SAWScript.Value
import SAWScript.Position
import SAWScript.Exceptions
import SAWScript.Options
import qualified SAWScript.Crucible.Common as Common
import SAWScript.Crucible.Common (Sym)
import SAWScript.Crucible.Common.MethodSpec (AllocIndex(..), nextAllocIndex, PrePost(..))
import qualified SAWScript.Crucible.Common.MethodSpec as MS
import SAWScript.Crucible.Common.MethodSpec (SetupValue(..))
import SAWScript.Crucible.Common.Override hiding (getSymInterface)
import qualified SAWScript.Crucible.Common.Setup.Builtins as Setup
import qualified SAWScript.Crucible.Common.Setup.Type as Setup
import SAWScript.Crucible.LLVM.Override
import SAWScript.Crucible.LLVM.ResolveSetupValue
import SAWScript.Crucible.LLVM.MethodSpecIR
type MemImpl = Crucible.MemImpl Sym
data LLVMVerificationException
= MultipleStaticFunctions L.Symbol
| DefNotFound L.Symbol [L.Symbol]
| DeclNotFound L.Symbol [L.Symbol]
| SetupError SetupError
displayVerifExceptionOpts :: Options -> LLVMVerificationException -> String
displayVerifExceptionOpts _ (MultipleStaticFunctions (L.Symbol nm)) =
"Multiple non-equal definitions for `" ++ nm ++ "`."
displayVerifExceptionOpts opts (DefNotFound (L.Symbol nm) nms) =
unlines $
[ "Could not find definition for function named `" ++ nm ++ "`."
] ++ if simVerbose opts < 3
then [ "Run SAW with --sim-verbose=3 to see all function names" ]
else "Available function names:" : map ((" " ++) . show . L.ppSymbol) nms
displayVerifExceptionOpts opts (DeclNotFound (L.Symbol nm) nms) =
unlines $
[ "Could not find declaration for function named `" ++ nm ++ "`."
] ++ if simVerbose opts < 3
then [ "Run SAW with --sim-verbose=3 to see all function names" ]
else "Available function names:" : map ((" " ++) . show . L.ppSymbol) nms
displayVerifExceptionOpts _ (SetupError e) =
"Error during simulation setup: " ++ show (ppSetupError e)
show_cfg :: SAW_CFG -> String
show_cfg (LLVM_CFG (Crucible.AnyCFG cfg)) = show cfg
show_cfg (JVM_CFG (Crucible.AnyCFG cfg)) = show cfg
-- | Determines whether one LLVM symbol is equivalent to another except
-- for a numeric suffix. This can determine whether one symbol is the
-- disambiguated name of a duplicated static function.
matchingStatics :: L.Symbol -> L.Symbol -> Bool
matchingStatics (L.Symbol a) (L.Symbol b) = go a b
where
go [] [] = True
go (x:xs) (y:ys) = x == y && go xs ys
go [] ('.':ds) = all isDigit ds
go ('.':ds) [] = all isDigit ds
go _ _ = False
findDefMaybeStatic :: L.Module -> String -> Either LLVMVerificationException (NE.NonEmpty L.Define)
findDefMaybeStatic llmod nm =
case NE.nonEmpty (filter (\d -> matchingStatics (L.defName d) nm') (L.modDefines llmod)) of
Nothing -> Left $ DefNotFound nm' $ map L.defName $ L.modDefines llmod
Just defs -> Right defs
where
nm' = fromString nm
findDecl :: L.Module -> String -> Either LLVMVerificationException L.Declare
findDecl llmod nm =
case find (\d -> (L.decName d) == nm') (L.modDeclares llmod) of
Just decl -> Right decl
Nothing -> Left $ DeclNotFound nm' $ map L.decName $ L.modDeclares llmod
where
nm' = fromString nm
resolveSpecName :: String -> TopLevel (String, Maybe String)
resolveSpecName nm =
if Crucible.testBreakpointFunction nm
then return
( (takeWhile (not . (== '#')) nm)
, Just (tail (dropWhile (not . (== '#')) nm))
)
else return (nm, Nothing)
crucible_llvm_verify ::
BuiltinContext ->
Options ->
Some LLVMModule ->
String ->
[SomeLLVM MS.CrucibleMethodSpecIR] ->
Bool ->
LLVMCrucibleSetupM () ->
ProofScript SatResult ->
TopLevel (SomeLLVM MS.CrucibleMethodSpecIR)
crucible_llvm_verify bic opts (Some lm) nm lemmas checkSat setup tactic =
do lemmas' <- checkModuleCompatibility lm lemmas
withMethodSpec bic opts lm nm setup $ \cc method_spec ->
do (res_method_spec, _) <- verifyMethodSpec bic opts cc method_spec lemmas' checkSat tactic Nothing
return $ SomeLLVM res_method_spec
crucible_llvm_unsafe_assume_spec ::
BuiltinContext ->
Options ->
Some LLVMModule ->
String {- ^ Name of the function -} ->
LLVMCrucibleSetupM () {- ^ Boundary specification -} ->
TopLevel (SomeLLVM MS.CrucibleMethodSpecIR)
crucible_llvm_unsafe_assume_spec bic opts (Some lm) nm setup =
withMethodSpec bic opts lm nm setup $ \_ method_spec ->
do printOutLnTop Info $
unwords ["Assume override", (method_spec ^. csName)]
return $ SomeLLVM method_spec
crucible_llvm_array_size_profile ::
BuiltinContext ->
Options ->
Some LLVMModule ->
String ->
LLVMCrucibleSetupM () ->
TopLevel [Crucible.Profile]
crucible_llvm_array_size_profile bic opts (Some lm) nm setup =
withMethodSpec bic opts lm nm setup $ \cc method_spec ->
do cell <- io $ newIORef Map.empty
void $ verifyMethodSpec bic opts cc method_spec [] False undefined (Just cell)
profiles <- io $ readIORef cell
pure $ Map.toList profiles
crucible_llvm_compositional_extract ::
BuiltinContext ->
Options ->
Some LLVMModule ->
String ->
String ->
[SomeLLVM MS.CrucibleMethodSpecIR] ->
Bool ->
LLVMCrucibleSetupM () ->
ProofScript SatResult ->
TopLevel (SomeLLVM MS.CrucibleMethodSpecIR)
crucible_llvm_compositional_extract bic opts (Some lm) nm func_name lemmas checkSat setup tactic =
do lemmas' <- checkModuleCompatibility lm lemmas
withMethodSpec bic opts lm nm setup $ \cc method_spec ->
do let value_input_parameters = mapMaybe
(\(_, setup_value) -> setupValueAsExtCns setup_value)
(Map.elems $ method_spec ^. MS.csArgBindings)
let reference_input_parameters = mapMaybe
(\(LLVMPointsTo _ _ _ setup_value) -> setupValueAsExtCns setup_value)
(method_spec ^. MS.csPreState ^. MS.csPointsTos)
let input_parameters = nub $ value_input_parameters ++ reference_input_parameters
let pre_free_variables = Map.fromList $
map (\x -> (fromJust $ asExtCns $ ttTerm x, x)) $ method_spec ^. MS.csPreState ^. MS.csFreshVars
let unsupported_input_parameters = Set.difference
(Map.keysSet pre_free_variables)
(Set.fromList input_parameters)
when (not $ Set.null unsupported_input_parameters) $
fail $ unlines
[ "Unsupported input parameters:"
, show unsupported_input_parameters
, "An input parameter must be bound by crucible_execute_func or crucible_points_to."
]
let return_output_parameter =
case method_spec ^. MS.csRetValue of
Just setup_value -> setupValueAsExtCns setup_value
Nothing -> Nothing
let reference_output_parameters =
mapMaybe
(\(LLVMPointsTo _ _ _ setup_value) -> setupValueAsExtCns setup_value)
(method_spec ^. MS.csPostState ^. MS.csPointsTos)
let output_parameters =
nub $ filter (isNothing . (Map.!?) pre_free_variables) $
maybeToList return_output_parameter ++ reference_output_parameters
let post_free_variables =
Map.fromList $
map (\x -> (fromJust $ asExtCns $ ttTerm x, x)) $ method_spec ^. MS.csPostState ^. MS.csFreshVars
let unsupported_output_parameters =
Set.difference (Map.keysSet post_free_variables) (Set.fromList output_parameters)
when (not $ Set.null unsupported_output_parameters) $
fail $ unlines
[ "Unsupported output parameters:"
, show unsupported_output_parameters
, "An output parameter must be bound by crucible_return or crucible_points_to."
]
(res_method_spec, post_override_state) <- verifyMethodSpec bic opts cc method_spec lemmas' checkSat tactic Nothing
let shared_context = biSharedContext bic
let output_values =
map (((Map.!) $ post_override_state ^. termSub) . ecVarIndex) output_parameters
extracted_func <-
io $ scAbstractExts shared_context input_parameters
=<< scTuple shared_context output_values
when ([] /= getAllExts extracted_func) $
fail "Non-functional simulation summary."
extracted_func_const <-
io $ scConstant shared_context func_name extracted_func
=<< scTypeOf shared_context extracted_func
let input_terms = map ttTerm $ map ((Map.!) pre_free_variables) input_parameters
applied_extracted_func <- io $ scApplyAll shared_context extracted_func_const input_terms
applied_extracted_func_selectors <-
io $ forM [1 .. (length output_parameters)] $ \i ->
mkTypedTerm shared_context
=<< scTupleSelector shared_context applied_extracted_func i (length output_parameters)
let output_parameter_substitution =
Map.fromList $
zip output_parameters applied_extracted_func_selectors
let substitute_output_parameter setup_value
| Just ext_cns <- setupValueAsExtCns setup_value
, Just x <- output_parameter_substitution Map.!? ext_cns =
SetupTerm x
| otherwise = setup_value
let extracted_method_spec =
res_method_spec &
MS.csRetValue %~ fmap substitute_output_parameter &
MS.csPostState . MS.csPointsTos %~ map
(\(LLVMPointsTo x y z setup_value) -> LLVMPointsTo x y z $ substitute_output_parameter setup_value)
typed_extracted_func_const <- io $ mkTypedTerm shared_context extracted_func_const
modify' $
extendEnv
(Located func_name func_name $ PosInternal "crucible_llvm_compositional_extract")
Nothing
Nothing
(VTerm typed_extracted_func_const)
return $ SomeLLVM extracted_method_spec
setupValueAsExtCns :: SetupValue (Crucible.LLVM arch) -> Maybe (ExtCns Term)
setupValueAsExtCns =
\case
SetupTerm term -> asExtCns $ ttTerm term
_ -> Nothing
-- | Check that all the overrides/lemmas were actually from this module
checkModuleCompatibility ::
LLVMModule arch ->
[SomeLLVM MS.CrucibleMethodSpecIR] ->
TopLevel [MS.CrucibleMethodSpecIR (LLVM arch)]
checkModuleCompatibility llvmModule = foldM step []
where
step accum (SomeLLVM lemma) =
case testEquality (lemma ^. MS.csCodebase) llvmModule of
Nothing -> throwTopLevel $ unlines
[ "Failed to apply an override that was verified against a"
, "different LLVM module"
]
Just Refl -> pure (lemma:accum)
withMethodSpec ::
BuiltinContext ->
Options ->
LLVMModule arch ->
String {- ^ Name of the function -} ->
LLVMCrucibleSetupM () {- ^ Boundary specification -} ->
((?lc :: Crucible.TypeContext, Crucible.HasPtrWidth (Crucible.ArchWidth arch), Crucible.HasLLVMAnn Sym) =>
LLVMCrucibleContext arch -> MS.CrucibleMethodSpecIR (LLVM arch) -> TopLevel a) ->
TopLevel a
withMethodSpec bic opts lm nm setup action =
do (nm', parent) <- resolveSpecName nm
let edef = findDefMaybeStatic (modAST lm) nm'
let edecl = findDecl (modAST lm) nm'
let mtrans = modTrans lm
defOrDecls <-
case (edef, edecl) of
(Right defs, _) -> return (NE.map Left defs)
(_, Right decl) -> return (Right decl NE.:| [])
(Left err, Left _) -> throwTopLevel (displayVerifExceptionOpts opts err)
let ?lc = mtrans ^. Crucible.transContext . Crucible.llvmTypeCtx
Crucible.llvmPtrWidth (mtrans ^. Crucible.transContext) $ \_ ->
fmap NE.head $ forM defOrDecls $ \defOrDecl ->
setupLLVMCrucibleContext bic opts lm $ \cc ->
do let sym = cc^.ccBackend
pos <- getPosition
let setupLoc = toW4Loc "_SAW_verify_prestate" pos
let est0 =
case defOrDecl of
Left def -> initialCrucibleSetupState cc def setupLoc parent
Right decl -> initialCrucibleSetupStateDecl cc decl setupLoc parent
st0 <- either (throwTopLevel . show . ppSetupError) return est0
-- execute commands of the method spec
io $ W4.setCurrentProgramLoc sym setupLoc
methodSpec <-
view Setup.csMethodSpec <$>
execStateT (runLLVMCrucibleSetupM setup) st0
io $ checkSpecArgumentTypes cc methodSpec
io $ checkSpecReturnType cc methodSpec
action cc methodSpec
verifyMethodSpec ::
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth (Crucible.ArchWidth arch), Crucible.HasLLVMAnn Sym) =>
BuiltinContext ->
Options ->
LLVMCrucibleContext arch ->
MS.CrucibleMethodSpecIR (LLVM arch) ->
[MS.CrucibleMethodSpecIR (LLVM arch)] ->
Bool ->
ProofScript SatResult ->
Maybe (IORef (Map Text.Text [[Maybe Int]])) ->
TopLevel (MS.CrucibleMethodSpecIR (LLVM arch), OverrideState (LLVM arch))
verifyMethodSpec bic opts cc methodSpec lemmas checkSat tactic asp =
do printOutLnTop Info $
unwords ["Verifying", (methodSpec ^. csName) , "..."]
let sym = cc^.ccBackend
profFile <- rwProfilingFile <$> getTopLevelRW
(writeFinalProfile, pfs) <- io $ Common.setupProfiling sym "crucible_llvm_verify" profFile
-- set up the LLVM memory with a pristine heap
let globals = cc^.ccLLVMGlobals
let mvar = Crucible.llvmMemVar (ccLLVMContext cc)
mem0 <-
case Crucible.lookupGlobal mvar globals of
Nothing -> fail "internal error: LLVM Memory global not found"
Just mem0 -> return mem0
-- push a memory stack frame if starting from a breakpoint
let mem = if isJust (methodSpec^.csParentName)
then mem0
{ Crucible.memImplHeap = Crucible.pushStackFrameMem
(Crucible.memImplHeap mem0)
}
else mem0
let globals1 = Crucible.llvmGlobals (ccLLVMContext cc) mem
-- construct the initial state for verifications
(args, assumes, env, globals2) <-
io $ verifyPrestate opts cc methodSpec globals1
-- save initial path conditions
frameIdent <- io $ Crucible.pushAssumptionFrame sym
-- run the symbolic execution
printOutLnTop Info $
unwords ["Simulating", (methodSpec ^. csName) , "..."]
top_loc <- toW4Loc "crucible_llvm_verify" <$> getPosition
(ret, globals3) <-
io $ verifySimulate opts cc pfs methodSpec args assumes top_loc lemmas globals2 checkSat asp
-- collect the proof obligations
(asserts, post_override_state) <-
verifyPoststate opts (biSharedContext bic) cc
methodSpec env globals3 ret
-- restore previous assumption state
_ <- io $ Crucible.popAssumptionFrame sym frameIdent
-- attempt to verify the proof obligations
printOutLnTop Info $
unwords ["Checking proof obligations", (methodSpec ^. csName), "..."]
stats <- verifyObligations cc methodSpec tactic assumes asserts
io $ writeFinalProfile
return (methodSpec & MS.csSolverStats .~ stats, post_override_state)
verifyObligations :: LLVMCrucibleContext arch
-> MS.CrucibleMethodSpecIR (LLVM arch)
-> ProofScript SatResult
-> [Crucible.LabeledPred Term Crucible.AssumptionReason]
-> [(String, Term)]
-> TopLevel SolverStats
verifyObligations cc mspec tactic assumes asserts =
do let sym = cc^.ccBackend
st <- io $ readIORef $ W4.sbStateManager sym
let sc = CrucibleSAW.saw_ctx st
assume <- io $ scAndList sc (toListOf (folded . Crucible.labeledPred) assumes)
let nm = mspec ^. csName
stats <-
forM (zip [(0::Int)..] asserts) $ \(n, (msg, assert)) ->
do goal <- io $ scImplies sc assume assert
goal' <- io $ scEqTrue sc goal
let goalname = concat [nm, " (", takeWhile (/= '\n') msg, ")"]
proofgoal = ProofGoal n "vc" goalname (Prop goal')
r <- evalStateT tactic (startProof proofgoal)
case r of
Unsat stats -> return stats
SatMulti stats vals ->
do printOutLnTop Info $ unwords ["Subgoal failed:", nm, msg]
printOutLnTop Info (show stats)
printOutLnTop OnlyCounterExamples "----------Counterexample----------"
opts <- sawPPOpts <$> rwPPOpts <$> getTopLevelRW
if null vals then
printOutLnTop OnlyCounterExamples "<<All settings of the symbolic variables constitute a counterexample>>"
else
let showAssignment (name, val) = " " ++ name ++ ": " ++ show (ppFirstOrderValue opts val) in
mapM_ (printOutLnTop OnlyCounterExamples . showAssignment) vals
printOutLnTop OnlyCounterExamples "----------------------------------"
throwTopLevel "Proof failed." -- Mirroring behavior of llvm_verify
printOutLnTop Info $ unwords ["Proof succeeded!", nm]
return (mconcat stats)
throwMethodSpec :: MS.CrucibleMethodSpecIR (LLVM arch) -> String -> IO a
throwMethodSpec mspec msg = X.throw $ LLVMMethodSpecException (mspec ^. MS.csLoc) msg
-- | Check that the specified arguments have the expected types.
--
-- The expected types are inferred from the LLVM module.
checkSpecArgumentTypes ::
Crucible.HasPtrWidth (Crucible.ArchWidth arch) =>
LLVMCrucibleContext arch ->
MS.CrucibleMethodSpecIR (LLVM arch) ->
IO ()
checkSpecArgumentTypes cc mspec = mapM_ resolveArg [0..(nArgs-1)]
where
nArgs = toInteger (length (mspec ^. MS.csArgs))
tyenv = MS.csAllocations mspec
nameEnv = mspec ^. MS.csPreState . MS.csVarTypeNames
nm = mspec^.csName
checkArgTy i mt mt' =
do b <- checkRegisterCompatibility mt mt'
unless b $
throwMethodSpec mspec $ unlines
[ "Type mismatch in argument " ++ show i ++ " when verifying " ++ show nm
, "Argument is declared with type: " ++ show mt
, "but provided argument has incompatible type: " ++ show mt'
, "Note: this may be because the signature of your " ++
"function changed during compilation. If using " ++
"Clang, check the signature in the disassembled " ++
".ll file."
]
resolveArg i =
case Map.lookup i (mspec ^. MS.csArgBindings) of
Just (mt, sv) -> do
mt' <- typeOfSetupValue cc tyenv nameEnv sv
checkArgTy i mt mt'
Nothing -> throwMethodSpec mspec $ unwords
["Argument", show i, "unspecified when verifying", show nm]
-- | Check that the specified return value has the expected type.
--
-- The expected type is inferred from the LLVM module.
--
-- TODO: generalize, put in Setup.Builtins
checkSpecReturnType ::
Crucible.HasPtrWidth (Crucible.ArchWidth arch) =>
LLVMCrucibleContext arch ->
MS.CrucibleMethodSpecIR (LLVM arch) ->
IO ()
checkSpecReturnType cc mspec =
case (mspec ^. MS.csRetValue, mspec ^. MS.csRet) of
(Just _, Nothing) ->
throwMethodSpec mspec $ unlines
[ "Could not resolve return type of " ++ mspec ^. csName
, "Raw type: " ++ show (mspec ^. MS.csRet)
]
(Just sv, Just retTy) ->
do retTy' <-
typeOfSetupValue cc
(MS.csAllocations mspec) -- map allocation indices to allocations
(mspec ^. MS.csPreState . MS.csVarTypeNames) -- map alloc indices to var names
sv
-- This check is too lax, see saw-script#443
b <- checkRegisterCompatibility retTy retTy'
unless b $ throwMethodSpec mspec $ unlines
[ "Incompatible types for return value when verifying " ++ mspec^.csName
, "Expected: " ++ show retTy
, "but given value of type: " ++ show retTy'
]
(Nothing, _) -> return ()
-- | Evaluate the precondition part of a Crucible method spec:
--
-- * Allocate heap space for each 'crucible_alloc' statement.
--
-- * Record an equality precondition for each 'crucible_equal'
-- statement.
--
-- * Write to memory for each 'crucible_points_to' statement. (Writes
-- to already-initialized locations are transformed into equality
-- preconditions.)
--
-- * Evaluate the function arguments from the 'crucible_execute_func'
-- statement.
--
-- Returns a tuple of (arguments, preconditions, pointer values,
-- memory).
verifyPrestate ::
(Crucible.HasPtrWidth (Crucible.ArchWidth arch), Crucible.HasLLVMAnn Sym) =>
Options ->
LLVMCrucibleContext arch ->
MS.CrucibleMethodSpecIR (LLVM arch) ->
Crucible.SymGlobalState Sym ->
IO ([(Crucible.MemType, LLVMVal)],
[Crucible.LabeledPred Term Crucible.AssumptionReason],
Map AllocIndex (LLVMPtr (Crucible.ArchWidth arch)),
Crucible.SymGlobalState Sym)
verifyPrestate opts cc mspec globals =
do let ?lc = ccTypeCtx cc
let sym = cc^.ccBackend
let prestateLoc = W4.mkProgramLoc "_SAW_verify_prestate" W4.InternalPos
liftIO $ W4.setCurrentProgramLoc sym prestateLoc
let lvar = Crucible.llvmMemVar (ccLLVMContext cc)
let Just mem = Crucible.lookupGlobal lvar globals
-- Allocate LLVM memory for each 'crucible_alloc'
(env1, mem') <- runStateT
(traverse (doAlloc cc) $ mspec ^. MS.csPreState . MS.csAllocs)
mem
env2 <-
Map.traverseWithKey
(\k _ -> executeFreshPointer cc k)
(mspec ^. MS.csPreState . MS.csFreshPointers)
let env = Map.unions [env1, env2]
mem'' <- setupGlobalAllocs cc mspec mem'
mem''' <- setupPrePointsTos mspec opts cc env (mspec ^. MS.csPreState . MS.csPointsTos) mem''
let globals1 = Crucible.insertGlobal lvar mem''' globals
(globals2,cs) <-
setupPrestateConditions mspec cc mem''' env globals1 (mspec ^. MS.csPreState . MS.csConditions)
args <- resolveArguments cc mem''' mspec env
return (args, cs, env, globals2)
-- | Check two MemTypes for register compatiblity. This is a stricter
-- check than the memory compatiblity check that is done for points-to
-- assertions.
checkRegisterCompatibility ::
(Crucible.HasPtrWidth wptr) =>
Crucible.MemType ->
Crucible.MemType ->
IO Bool
checkRegisterCompatibility mt mt' =
do st <- Crucible.toStorableType mt
st' <- Crucible.toStorableType mt'
return (st == st')
resolveArguments ::
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth (Crucible.ArchWidth arch)) =>
LLVMCrucibleContext arch ->
Crucible.MemImpl Sym ->
MS.CrucibleMethodSpecIR (LLVM arch) ->
Map AllocIndex (LLVMPtr (Crucible.ArchWidth arch)) ->
IO [(Crucible.MemType, LLVMVal)]
resolveArguments cc mem mspec env = mapM resolveArg [0..(nArgs-1)]
where
nArgs = toInteger (length (mspec ^. MS.csArgs))
tyenv = MS.csAllocations mspec
nameEnv = mspec ^. MS.csPreState . MS.csVarTypeNames
nm = mspec^.csName
resolveArg i =
case Map.lookup i (mspec ^. MS.csArgBindings) of
Just (mt, sv) -> do
v <- resolveSetupVal cc mem env tyenv nameEnv sv
return (mt, v)
Nothing -> throwMethodSpec mspec $ unwords
["Argument", show i, "unspecified when verifying", show nm]
--------------------------------------------------------------------------------
-- | For each "crucible_global_alloc" in the method specification, allocate and
-- register the appropriate memory.
setupGlobalAllocs :: forall arch.
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth (Crucible.ArchWidth arch)) =>
LLVMCrucibleContext arch ->
MS.CrucibleMethodSpecIR (LLVM arch) ->
MemImpl ->
IO MemImpl
setupGlobalAllocs cc mspec mem0 = foldM go mem0 $ mspec ^. MS.csGlobalAllocs
where
sym = cc ^. ccBackend
go :: MemImpl -> MS.AllocGlobal (LLVM arch) -> IO MemImpl
go mem (LLVMAllocGlobal _ symbol@(L.Symbol name)) = do
let mtrans = ccLLVMModuleTrans cc
gimap = Crucible.globalInitMap mtrans
case Map.lookup symbol gimap of
Just (g, Right (mt, _)) ->
do when (L.gaConstant $ L.globalAttrs g) . throwMethodSpec mspec $ mconcat
[ "Global variable \""
, name
, "\" is not mutable"
]
let sz = Crucible.memTypeSize (Crucible.llvmDataLayout ?lc) mt
sz' <- W4.bvLit sym ?ptrWidth $ Crucible.bytesToBV ?ptrWidth sz
alignment <-
case L.globalAlign g of
Just a | a > 0 ->
case Crucible.toAlignment $ Crucible.toBytes a of
Nothing -> throwMethodSpec mspec $ mconcat
[ "Global variable \""
, name
, "\" has invalid alignment: "
, show a
]
Just al -> return al
_ -> pure $ Crucible.memTypeAlign (Crucible.llvmDataLayout ?lc) mt
(ptr, mem') <- Crucible.doMalloc sym Crucible.GlobalAlloc Crucible.Mutable name mem sz' alignment
pure $ Crucible.registerGlobal mem' [symbol] ptr
_ -> throwMethodSpec mspec $ mconcat
[ "Global variable \""
, name
, "\" does not exist"
]
-- | For each points-to constraint in the pre-state section of the
-- function spec, write the given value to the address of the given
-- pointer.
setupPrePointsTos :: forall arch.
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth (Crucible.ArchWidth arch), Crucible.HasLLVMAnn Sym) =>
MS.CrucibleMethodSpecIR (LLVM arch) ->
Options ->
LLVMCrucibleContext arch ->
Map AllocIndex (LLVMPtr (Crucible.ArchWidth arch)) ->
[MS.PointsTo (LLVM arch)] ->
MemImpl ->
IO MemImpl
setupPrePointsTos mspec opts cc env pts mem0 = foldM go mem0 pts
where
tyenv = MS.csAllocations mspec
nameEnv = mspec ^. MS.csPreState . MS.csVarTypeNames
go :: MemImpl -> MS.PointsTo (LLVM arch) -> IO MemImpl
go mem (LLVMPointsTo _loc cond ptr val) =
do ptr' <- resolveSetupVal cc mem env tyenv nameEnv ptr
ptr'' <- case ptr' of
Crucible.LLVMValInt blk off
| Just Refl <- testEquality (W4.bvWidth off) Crucible.PtrWidth
-> return (Crucible.LLVMPointer blk off)
_ -> throwMethodSpec mspec "Non-pointer value found in points-to assertion"
cond' <- mapM (resolveSAWPred cc . ttTerm) cond
storePointsToValue opts cc env tyenv nameEnv mem cond' ptr'' val Nothing
-- | Sets up globals (ghost variable), and collects boolean terms
-- that should be assumed to be true.
setupPrestateConditions ::
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth (Crucible.ArchWidth arch)) =>
MS.CrucibleMethodSpecIR (LLVM arch) ->
LLVMCrucibleContext arch ->
Crucible.MemImpl Sym ->
Map AllocIndex (LLVMPtr (Crucible.ArchWidth arch)) ->
Crucible.SymGlobalState Sym ->
[MS.SetupCondition (LLVM arch)] ->
IO (Crucible.SymGlobalState Sym, [Crucible.LabeledPred Term Crucible.AssumptionReason])
setupPrestateConditions mspec cc mem env = aux []
where
tyenv = MS.csAllocations mspec
nameEnv = mspec ^. MS.csPreState . MS.csVarTypeNames
aux acc globals [] = return (globals, acc)
aux acc globals (MS.SetupCond_Equal loc val1 val2 : xs) =
do val1' <- resolveSetupVal cc mem env tyenv nameEnv val1
val2' <- resolveSetupVal cc mem env tyenv nameEnv val2
t <- assertEqualVals cc val1' val2'
let lp = Crucible.LabeledPred t (Crucible.AssumptionReason loc "equality precondition")
aux (lp:acc) globals xs
aux acc globals (MS.SetupCond_Pred loc tm : xs) =
let lp = Crucible.LabeledPred (ttTerm tm) (Crucible.AssumptionReason loc "precondition") in
aux (lp:acc) globals xs
aux acc globals (MS.SetupCond_Ghost () _loc var val : xs) =
aux acc (Crucible.insertGlobal var val globals) xs
--------------------------------------------------------------------------------
-- | Create a SAWCore formula asserting that two 'LLVMVal's are equal.
assertEqualVals ::
LLVMCrucibleContext arch ->
LLVMVal ->
LLVMVal ->
IO Term
assertEqualVals cc v1 v2 =
CrucibleSAW.toSC (cc^.ccBackend) =<< equalValsPred cc v1 v2
--------------------------------------------------------------------------------
-- TODO(langston): combine with/move to executeAllocation
doAlloc ::
(Crucible.HasPtrWidth (Crucible.ArchWidth arch)) =>
LLVMCrucibleContext arch ->
LLVMAllocSpec ->
StateT MemImpl IO (LLVMPtr (Crucible.ArchWidth arch))
doAlloc cc (LLVMAllocSpec mut _memTy alignment sz loc) = StateT $ \mem ->
do let sym = cc^.ccBackend
sz' <- W4.bvLit sym Crucible.PtrWidth $ Crucible.bytesToBV Crucible.PtrWidth sz
let l = show (W4.plSourceLoc loc)
liftIO $
Crucible.doMalloc sym Crucible.HeapAlloc mut l mem sz' alignment
--------------------------------------------------------------------------------
ppAbortedResult :: LLVMCrucibleContext arch
-> Crucible.AbortedResult Sym a
-> Doc
ppAbortedResult cc = Common.ppAbortedResult (ppGlobalPair cc)
ppGlobalPair :: LLVMCrucibleContext arch
-> Crucible.GlobalPair Sym a
-> Doc
ppGlobalPair cc gp =
let mvar = Crucible.llvmMemVar (ccLLVMContext cc)
globals = gp ^. Crucible.gpGlobals in
case Crucible.lookupGlobal mvar globals of
Nothing -> text "LLVM Memory global variable not initialized"
Just mem -> Crucible.ppMem mem
--------------------------------------------------------------------------------
registerOverride ::
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth wptr, wptr ~ Crucible.ArchWidth arch, Crucible.HasLLVMAnn Sym) =>
Options ->
LLVMCrucibleContext arch ->
Crucible.SimContext (CrucibleSAW.SAWCruciblePersonality Sym) Sym (Crucible.LLVM arch) ->
W4.ProgramLoc ->
[MS.CrucibleMethodSpecIR (LLVM arch)] ->
Crucible.OverrideSim (CrucibleSAW.SAWCruciblePersonality Sym) Sym (Crucible.LLVM arch) rtp args ret ()
registerOverride opts cc sim_ctx top_loc cs =
do let sym = cc^.ccBackend
sc <- CrucibleSAW.saw_ctx <$> liftIO (readIORef (W4.sbStateManager sym))
let fstr = (head cs)^.csName
fsym = L.Symbol fstr
llvmctx = ccLLVMContext cc
mvar = Crucible.llvmMemVar llvmctx
halloc = Crucible.simHandleAllocator sim_ctx
matches dec = matchingStatics (L.decName dec) fsym
liftIO $
printOutLn opts Info $ "Registering overrides for `" ++ fstr ++ "`"
case filter matches (Crucible.allModuleDeclares (ccLLVMModuleAST cc)) of
[] -> fail $ "Couldn't find declaration for `" ++ fstr ++ "` when registering override for it."
(d:ds) ->
Crucible.llvmDeclToFunHandleRepr' d $ \argTypes retType ->
do let fn_name = W4.functionNameFromText $ Text.pack fstr
h <- liftIO $ Crucible.mkHandle' halloc fn_name argTypes retType
Crucible.bindFnHandle h
$ Crucible.UseOverride
$ Crucible.mkOverride' fn_name retType
$ methodSpecHandler opts sc cc top_loc cs h
mem <- Crucible.readGlobal mvar
let bindPtr m decl =
do printOutLn opts Info $ " variant `" ++ show (L.decName decl) ++ "`"
Crucible.bindLLVMFunPtr sym decl h m
mem' <- liftIO $ foldM bindPtr mem (d:ds)
Crucible.writeGlobal mvar mem'
registerInvariantOverride ::
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth (Crucible.ArchWidth arch), Crucible.HasLLVMAnn Sym) =>
Options ->
LLVMCrucibleContext arch ->
W4.ProgramLoc ->
HashMap Crucible.SomeHandle [Crucible.BreakpointName] ->
[MS.CrucibleMethodSpecIR (LLVM arch)] ->
IO (Crucible.ExecutionFeature (CrucibleSAW.SAWCruciblePersonality Sym) Sym (Crucible.LLVM arch) rtp)
registerInvariantOverride opts cc top_loc all_breakpoints cs =
do sc <- CrucibleSAW.saw_ctx <$> (liftIO $ readIORef $ W4.sbStateManager $ cc^.ccBackend)
let name = (head cs) ^. csName
parent <-
case nubOrd $ map (view csParentName) cs of
[Just unique_parent] -> return unique_parent
_ -> fail $ "Multiple parent functions for breakpoint: " ++ name
liftIO $ printOutLn opts Info $ "Registering breakpoint `" ++ name ++ "`"
withBreakpointCfgAndBlockId cc name parent $ \cfg breakpoint_block_id ->
do let breakpoint_name = Crucible.BreakpointName $ Text.pack name
let h = Crucible.cfgHandle cfg
let arg_types = Crucible.blockInputs $
Crucible.getBlock breakpoint_block_id $
Crucible.cfgBlockMap cfg
let ret_type = Crucible.handleReturnType h
let halloc = Crucible.simHandleAllocator (cc ^. ccLLVMSimContext)
hInvariant <- Crucible.mkHandle' halloc (W4.plFunction top_loc) arg_types ret_type
Crucible.breakAndReturn
cfg
breakpoint_name
arg_types
ret_type
(methodSpecHandler opts sc cc top_loc cs hInvariant)
all_breakpoints
--------------------------------------------------------------------------------
withCfg ::
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth (Crucible.ArchWidth arch), Crucible.HasLLVMAnn Sym) =>
LLVMCrucibleContext arch ->
String ->
(forall blocks init ret . Crucible.CFG (Crucible.LLVM arch) blocks init ret -> IO a) ->
IO a
withCfg context name k =
do let function_id = L.Symbol name
case Map.lookup function_id (Crucible.cfgMap (ccLLVMModuleTrans context)) of
Just (_, Crucible.AnyCFG cfg) -> k cfg
Nothing -> fail $ "Unexpected function name: " ++ name
withCfgAndBlockId ::
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth (Crucible.ArchWidth arch), Crucible.HasLLVMAnn Sym) =>
LLVMCrucibleContext arch ->
MS.CrucibleMethodSpecIR (LLVM arch) ->
(forall blocks init args ret . Crucible.CFG (Crucible.LLVM arch) blocks init ret -> Crucible.BlockID blocks args -> IO a) ->
IO a
withCfgAndBlockId context method_spec k =
case method_spec ^. csParentName of
Nothing -> withCfg context (method_spec ^. csName) $ \cfg ->
k cfg (Crucible.cfgEntryBlockID cfg)
Just parent -> withBreakpointCfgAndBlockId
context
(method_spec ^. csName)
parent
k
withBreakpointCfgAndBlockId ::
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth (Crucible.ArchWidth arch), Crucible.HasLLVMAnn Sym) =>
LLVMCrucibleContext arch ->
String ->
String ->
(forall blocks init args ret . Crucible.CFG (Crucible.LLVM arch) blocks init ret -> Crucible.BlockID blocks args -> IO a) ->
IO a
withBreakpointCfgAndBlockId context name parent k =
do let breakpoint_name = Crucible.BreakpointName $ Text.pack name
withCfg context parent $ \cfg ->
case Bimap.lookup breakpoint_name (Crucible.cfgBreakpoints cfg) of
Just (Some breakpoint_block_id) -> k cfg breakpoint_block_id
Nothing -> fail $ "Unexpected breakpoint name: " ++ name
verifySimulate ::
(?lc :: Crucible.TypeContext, Crucible.HasPtrWidth wptr, wptr ~ Crucible.ArchWidth arch, Crucible.HasLLVMAnn Sym) =>
Options ->
LLVMCrucibleContext arch ->
[Crucible.GenericExecutionFeature Sym] ->